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     my $warnings = $op->warnings;
 297     my $warningsix = $warnings->objix;
 298     if ($debug_bc) {
 299         printf "# line %s:%d\n", $filegv->SV->PV, $line;
 300     }
 301     $op->B::OP::bytecode;
 302     printf <<"EOT", pvstring($op->label), $op->cop_seq, $op->arybase;
 303 newpv %s
 304 cop_label
 305 cop_stash $stashix
 306 cop_seq %d
 307 cop_filegv $filegvix
 308 cop_arybase %d
 309 cop_line $line
 310 cop_warnings $warningsix
 311 EOT
 312     $filegv->bytecode;
 313     $stash->bytecode;
 314 }
 315
 316 sub B::PMOP::bytecode {
 317     my $op = shift;
 318     my $replroot = $op->pmreplroot;
 319     my $replrootix = $replroot->objix;
 320     my $replstartix = $op->pmreplstart->objix;
 321     my $ppaddr = $op->ppaddr;
 322     # pmnext is corrupt in some PMOPs (see misc.t for example)
 323     #my $pmnextix = $op->pmnext->objix;
 324
 325     if ($$replroot) {
 326         # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
 327         # argument to a split) stores a GV in op_pmreplroot instead
 328         # of a substitution syntax tree. We don't want to walk that...
 329         if ($ppaddr eq "pp_pushre") {
 330             $replroot->bytecode;
 331         } else {
 332             walkoptree($replroot, "bytecode");
 333         }
 334     }
 335     $op->B::LISTOP::bytecode;
 336     if ($ppaddr eq "pp_pushre") {
 337         printf "op_pmreplrootgv $replrootix\n";
 338     } else {
 339         print "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n";
 340     }
 341     my $re = pvstring($op->precomp);
 342     # op_pmnext omitted since a perl bug means it's sometime corrupt
 343     printf <<"EOT", $op->pmflags, $op->pmpermflags;
 344 op_pmflags 0x%x
 345 op_pmpermflags 0x%x
 346 newpv $re
 347 pregcomp
 348 EOT
 349 }
 350
 351 sub B::SV::bytecode {
 352     my $sv = shift;
 353     return if saved($sv);
 354     my $ix = $sv->objix;
 355     my $refcnt = $sv->REFCNT;
 356     my $flags = sprintf("0x%x", $sv->FLAGS);
 357     ldsv($ix);
 358     print "sv_refcnt $refcnt\nsv_flags $flags\n";
 359     mark_saved($sv);
 360 }
 361
 362 sub B::PV::bytecode {
 363     my $sv = shift;
 364     return if saved($sv);
 365     $sv->B::SV::bytecode;
 366     printf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK;
 367 }
 368
 369 sub B::IV::bytecode {
 370     my $sv = shift;
 371     return if saved($sv);
 372     my $iv = $sv->IVX;
 373     $sv->B::SV::bytecode;
 374     printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32";
 375 }
 376
 377 sub B::NV::bytecode {
 378     my $sv = shift;
 379     return if saved($sv);
 380     $sv->B::SV::bytecode;
 381     printf "xnv %s\n", $sv->NVX;
 382 }
 383
 384 sub B::RV::bytecode {
 385     my $sv = shift;
 386     return if saved($sv);
 387     my $rv = $sv->RV;
 388     my $rvix = $rv->objix;
 389     $rv->bytecode;
 390     $sv->B::SV::bytecode;
 391     print "xrv $rvix\n";
 392 }
 393
 394 sub B::PVIV::bytecode {
 395     my $sv = shift;
 396     return if saved($sv);
 397     my $iv = $sv->IVX;
 398     $sv->B::PV::bytecode;
 399     printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32";
 400 }
 401
 402 sub B::PVNV::bytecode {
 403     my ($sv, $flag) = @_;
 404     # The $flag argument is passed through PVMG::bytecode by BM::bytecode
 405     # and AV::bytecode and indicates special handling. $flag = 1 is used by
 406     # BM::bytecode and means that we should ensure we save the whole B-M
 407     # table. It consists of 257 bytes (256 char array plus a final \0)
 408     # which follow the ordinary PV+\0 and the 257 bytes are *not* reflected
 409     # in SvCUR. $flag = 2 is used by AV::bytecode and means that we only
 410     # call SV::bytecode instead of saving PV and calling NV::bytecode since
 411     # PV/NV/IV stuff is different for AVs.
 412     return if saved($sv);
 413     if ($flag == 2) {
 414         $sv->B::SV::bytecode;
 415     } else {
 416         my $pv = $sv->PV;
 417         $sv->B::IV::bytecode;
 418         printf "xnv %s\n", $sv->NVX;
 419         if ($flag == 1) {
 420             $pv .= "\0" . $sv->TABLE;
 421             printf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257;
 422         } else {
 423             printf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK;
 424         }
 425     }
 426 }
 427
 428 sub B::PVMG::bytecode {
 429     my ($sv, $flag) = @_;
 430     # See B::PVNV::bytecode for an explanation of $flag.
 431     return if saved($sv);
 432     # XXX We assume SvSTASH is already saved and don't save it later ourselves
 433     my $stashix = $sv->SvSTASH->objix;
 434     my @mgchain = $sv->MAGIC;
 435     my (@mgobjix, $mg);
 436     #
 437     # We need to traverse the magic chain and get objix for each OBJ
 438     # field *before* we do B::PVNV::bytecode since objix overwrites
 439     # the sv register. However, we need to write the magic-saving
 440     # bytecode *after* B::PVNV::bytecode since sv isn't initialised
 441     # to refer to $sv until then.
 442     #
 443     @mgobjix = map($_->OBJ->objix, @mgchain);
 444     $sv->B::PVNV::bytecode($flag);
 445     print "xmg_stash $stashix\n";
 446     foreach $mg (@mgchain) {
 447         printf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n",
 448             cstring($mg->TYPE), shift(@mgobjix), pvstring($mg->PTR);
 449     }
 450 }
 451
 452 sub B::PVLV::bytecode {
 453     my $sv = shift;
 454     return if saved($sv);
 455     $sv->B::PVMG::bytecode;
 456     printf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE);
 457 xlv_targoff %d
 458 xlv_targlen %d
 459 xlv_type %s
 460 EOT
 461 }
 462
 463 sub B::BM::bytecode {
 464     my $sv = shift;
 465     return if saved($sv);
 466     # See PVNV::bytecode for an explanation of what the argument does
 467     $sv->B::PVMG::bytecode(1);
 468     printf "xbm_useful %d\nxbm_previous %d\nxbm_rare %d\n",
 469         $sv->USEFUL, $sv->PREVIOUS, $sv->RARE;
 470 }
 471
 472 sub B::GV::bytecode {
 473     my $gv = shift;
 474     return if saved($gv);
 475     my $ix = $gv->objix;
 476     mark_saved($gv);
 477     my $gvname = $gv->NAME;
 478     my $name = cstring($gv->STASH->NAME . "::" . $gvname);
 479     my $egv = $gv->EGV;
 480     my $egvix = $egv->objix;
 481     ldsv($ix);
 482     printf <<"EOT", $gv->FLAGS, $gv->GvFLAGS, $gv->LINE;
 483 sv_flags 0x%x
 484 xgv_flags 0x%x
 485 gp_line %d
 486 EOT
 487     my $refcnt = $gv->REFCNT;
 488     printf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1;
 489     my $gvrefcnt = $gv->GvREFCNT;
 490     printf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1;
 491     if ($gvrefcnt > 1 &&  $ix != $egvix) {
 492         print "gp_share $egvix\n";
 493     } else {
 494         if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
 495             my $i;
 496             my @subfield_names = qw(SV AV HV CV FILEGV FORM IO);
 497             my @subfields = map($gv->$_(), @subfield_names);
 498             my @ixes = map($_->objix, @subfields);
 499             # Reset sv register for $gv
 500             ldsv($ix);
 501             for ($i = 0; $i < @ixes; $i++) {
 502                 printf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
 503             }
 504             # Now save all the subfields
 505             my $sv;
 506             foreach $sv (@subfields) {
 507                 $sv->bytecode;
 508             }
 509         }
 510     }
 511 }
 512
 513 sub B::HV::bytecode {
 514     my $hv = shift;
 515     return if saved($hv);
 516     mark_saved($hv);
 517     my $name = $hv->NAME;
 518     my $ix = $hv->objix;
 519     if (!$name) {
 520         # It's an ordinary HV. Stashes have NAME set and need no further
 521         # saving beyond the gv_stashpv that $hv->objix already ensures.
 522         my @contents = $hv->ARRAY;
 523         my ($i, @ixes);
 524         for ($i = 1; $i < @contents; $i += 2) {
 525             push(@ixes, $contents[$i]->objix);
 526         }
 527         for ($i = 1; $i < @contents; $i += 2) {
 528             $contents[$i]->bytecode;
 529         }
 530         ldsv($ix);
 531         for ($i = 0; $i < @contents; $i += 2) {
 532             printf("newpv %s\nhv_store %d\n",
 533                    pvstring($contents[$i]), $ixes[$i / 2]);
 534         }
 535         printf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS;
 536     }
 537 }
 538
 539 sub B::AV::bytecode {
 540     my $av = shift;
 541     return if saved($av);
 542     my $ix = $av->objix;
 543     my $fill = $av->FILL;
 544     my $max = $av->MAX;
 545     my (@array, @ixes);
 546     if ($fill > -1) {
 547         @array = $av->ARRAY;
 548         @ixes = map($_->objix, @array);
 549         my $sv;
 550         foreach $sv (@array) {
 551             $sv->bytecode;
 552         }
 553     }
 554     # See PVNV::bytecode for the meaning of the flag argument of 2.
 555     $av->B::PVMG::bytecode(2);
 556     # Recover sv register and set AvMAX and AvFILL to -1 (since we
 557     # create an AV with NEWSV and SvUPGRADE rather than doing newAV
 558     # which is what sets AvMAX and AvFILL.
 559     ldsv($ix);
 560     printf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS;
 561     if ($fill > -1) {
 562         my $elix;
 563         foreach $elix (@ixes) {
 564             print "av_push $elix\n";
 565         }
 566     } else {
 567         if ($max > -1) {
 568             print "av_extend $max\n";
 569         }
 570     }
 571 }
 572
 573 sub B::CV::bytecode {
 574     my $cv = shift;
 575     return if saved($cv);
 576     my $ix = $cv->objix;
 577     $cv->B::PVMG::bytecode;
 578     my $i;
 579     my @subfield_names = qw(ROOT START STASH GV FILEGV PADLIST OUTSIDE);
 580     my @subfields = map($cv->$_(), @subfield_names);
 581     my @ixes = map($_->objix, @subfields);
 582     # Save OP tree from CvROOT (first element of @subfields)
 583     my $root = shift @subfields;
 584     if ($$root) {
 585         walkoptree($root, "bytecode");
 586     }
 587     # Reset sv register for $cv (since above ->objix calls stomped on it)
 588     ldsv($ix);
 589     for ($i = 0; $i < @ixes; $i++) {
 590         printf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
 591     }
 592     printf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->FLAGS;
 593     # Now save all the subfields (except for CvROOT which was handled
 594     # above) and CvSTART (now the initial element of @subfields).
 595     shift @subfields; # bye-bye CvSTART
 596     my $sv;
 597     foreach $sv (@subfields) {
 598         $sv->bytecode;
 599     }
 600 }
 601
 602 sub B::IO::bytecode {
 603     my $io = shift;
 604     return if saved($io);
 605     my $ix = $io->objix;
 606     my $top_gv = $io->TOP_GV;
 607     my $top_gvix = $top_gv->objix;
 608     my $fmt_gv = $io->FMT_GV;
 609     my $fmt_gvix = $fmt_gv->objix;
 610     my $bottom_gv = $io->BOTTOM_GV;
 611     my $bottom_gvix = $bottom_gv->objix;
 612
 613     $io->B::PVMG::bytecode;
 614     ldsv($ix);
 615     print "xio_top_gv $top_gvix\n";
 616     print "xio_fmt_gv $fmt_gvix\n";
 617     print "xio_bottom_gv $bottom_gvix\n";
 618     my $field;
 619     foreach $field (qw(TOP_NAME FMT_NAME BOTTOM_NAME)) {
 620         printf "newpv %s\nxio_%s\n", pvstring($io->$field()), lc($field);
 621     }
 622     foreach $field (qw(LINES PAGE PAGE_LEN LINES_LEFT SUBPROCESS)) {
 623         printf "xio_%s %d\n", lc($field), $io->$field();
 624     }
 625     printf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS;
 626     $top_gv->bytecode;
 627     $fmt_gv->bytecode;
 628     $bottom_gv->bytecode;
 629 }
 630
 631 sub B::SPECIAL::bytecode {
 632     # nothing extra needs doing
 633 }
 634
 635 sub bytecompile_object {
 636     my $sv;
 637     foreach $sv (@_) {
 638         svref_2object($sv)->bytecode;
 639     }
 640 }
 641
 642 sub B::GV::bytecodecv {
 643     my $gv = shift;
 644     my $cv = $gv->CV;
 645     if ($$cv && !saved($cv)) {
 646         if ($debug_cv) {
 647             warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
 648                          $gv->STASH->NAME, $gv->NAME, $$cv, $$gv);
 649         }
 650         $gv->bytecode;
 651     }
 652 }
 653
 654 sub bytecompile_main {
 655     my $curpad = (comppadlist->ARRAY)[1];
 656     my $curpadix = $curpad->objix;
 657     $curpad->bytecode;
 658     walkoptree(main_root, "bytecode");
 659     warn "done main program, now walking symbol table\n" if $debug_bc;
 660     my ($pack, %exclude);
 661     foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS strict vars
 662                       FileHandle Exporter Carp UNIVERSAL IO Fcntl Symbol
 663                       SelectSaver blib Cwd))
 664     {
 665         $exclude{$pack."::"} = 1;
 666     }
 667     no strict qw(vars refs);
 668     walksymtable(\%{"main::"}, "bytecodecv", sub {
 669         warn "considering $_[0]\n" if $debug_bc;
 670         return !defined($exclude{$_[0]});
 671     });
 672     if (!$module_only) {
 673         printf "main_root %d\n", main_root->objix;
 674         printf "main_start %d\n", main_start->objix;
 675         printf "curpad $curpadix\n";
 676         # XXX Do min_intro_pending and max_intro_pending matter?
 677     }
 678 }
 679
 680 sub prepare_assemble {
 681     my $newfh = IO::File->new_tmpfile;
 682     select($newfh);
 683     binmode $newfh;
 684     return $newfh;
 685 }
 686
 687 sub do_assemble {
 688     my $fh = shift;
 689     seek($fh, 0, 0); # rewind the temporary file
 690     assemble_fh($fh, sub { print OUT @_ });
 691 }
 692
 693 sub compile {
 694     my @options = @_;
 695     my ($option, $opt, $arg);
 696     open(OUT, ">&STDOUT");
 697     binmode OUT;
 698     select(OUT);
 699   OPTION:
 700     while ($option = shift @options) {
 701         if ($option =~ /^-(.)(.*)/) {
 702             $opt = $1;
 703             $arg = $2;
 704         } else {
 705             unshift @options, $option;
 706             last OPTION;
 707         }
 708         if ($opt eq "-" && $arg eq "-") {
 709             shift @options;
 710             last OPTION;
 711         } elsif ($opt eq "o") {
 712             $arg ||= shift @options;
 713             open(OUT, ">$arg") or return "$arg: $!\n";
 714             binmode OUT;
 715         } elsif ($opt eq "D") {
 716             $arg ||= shift @options;
 717             foreach $arg (split(//, $arg)) {
 718                 if ($arg eq "b") {
 719                     $| = 1;
 720                     debug(1);
 721                 } elsif ($arg eq "o") {
 722                     B->debug(1);
 723                 } elsif ($arg eq "a") {
 724                     B::Assembler::debug(1);
 725                 } elsif ($arg eq "C") {
 726                     $debug_cv = 1;
 727                 }
 728             }
 729         } elsif ($opt eq "v") {
 730             $verbose = 1;
 731         } elsif ($opt eq "m") {
 732             $module_only = 1;
 733         } elsif ($opt eq "S") {
 734             $no_assemble = 1;
 735         } elsif ($opt eq "f") {
 736             $arg ||= shift @options;
 737             my $value = $arg !~ s/^no-//;
 738             $arg =~ s/-/_/g;
 739             my $ref = $optimise{$arg};
 740             if (defined($ref)) {
 741                 $$ref = $value;
 742             } else {
 743                 warn qq(ignoring unknown optimisation option "$arg"\n);
 744             }
 745         } elsif ($opt eq "O") {
 746             $arg = 1 if $arg eq "";
 747             my $ref;
 748             foreach $ref (values %optimise) {
 749                 $$ref = 0;
 750             }
 751             if ($arg >= 6) {
 752                 $strip_syntree = 1;
 753             }
 754             if ($arg >= 2) {
 755                 $bypass_nullops = 1;
 756             }
 757             if ($arg >= 1) {
 758                 $compress_nullops = 1;
 759                 $omit_seq = 1;
 760             }
 761         }
 762     }
 763     if (@options) {
 764         return sub {
 765             my $objname;
 766             my $newfh;
 767             $newfh = prepare_assemble() unless $no_assemble;
 768             foreach $objname (@options) {
 769                 eval "bytecompile_object(\\$objname)";
 770             }
 771             do_assemble($newfh) unless $no_assemble;
 772         }
 773     } else {
 774         return sub {
 775             my $newfh;
 776             $newfh = prepare_assemble() unless $no_assemble;
 777             bytecompile_main();
 778             do_assemble($newfh) unless $no_assemble;
 779         }
 780     }
 781 }
 782
 783 1;
 784
 785 __END__
 786
 787 =head1 NAME
 788
 789 B::Bytecode - Perl compiler's bytecode backend
 790
 791 =head1 SYNOPSIS
 792
 793         perl -MO=Bytecode[,OPTIONS] foo.pl
 794
 795 =head1 DESCRIPTION
 796
 797 This compiler backend takes Perl source and generates a
 798 platform-independent bytecode encapsulating code to load the
 799 internal structures perl uses to run your program. When the
 800 generated bytecode is loaded in, your program is ready to run,
 801 reducing the time which perl would have taken to load and parse
 802 your program into its internal semi-compiled form. That means that
 803 compiling with this backend will not help improve the runtime
 804 execution speed of your program but may improve the start-up time.
 805 Depending on the environment in which your program runs this may
 806 or may not be a help.
 807
 808 The resulting bytecode can be run with a special byteperl executable
 809 or (for non-main programs) be loaded via the C<byteload_fh> function
 810 in the F<B> module.
 811
 812 =head1 OPTIONS
 813
 814 If there are any non-option arguments, they are taken to be names of
 815 objects to be saved (probably doesn't work properly yet).  Without
 816 extra arguments, it saves the main program.
 817
 818 =over 4
 819
 820 =item B<-ofilename>
 821
 822 Output to filename instead of STDOUT.
 823
 824 =item B<-->
 825
 826 Force end of options.
 827
 828 =item B<-f>
 829
 830 Force optimisations on or off one at a time. Each can be preceded
 831 by B<no-> to turn the option off (e.g. B<-fno-compress-nullops>).
 832
 833 =item B<-fcompress-nullops>
 834
 835 Only fills in the necessary fields of ops which have
 836 been optimised away by perl's internal compiler.
 837
 838 =item B<-fomit-sequence-numbers>
 839
 840 Leaves out code to fill in the op_seq field of all ops
 841 which is only used by perl's internal compiler.
 842
 843 =item B<-fbypass-nullops>
 844
 845 If op->op_next ever points to a NULLOP, replaces the op_next field
 846 with the first non-NULLOP in the path of execution.
 847
 848 =item B<-fstrip-syntax-tree>
 849
 850 Leaves out code to fill in the pointers which link the internal syntax
 851 tree together. They're not needed at run-time but leaving them out
 852 will make it impossible to recompile or disassemble the resulting
 853 program.  It will also stop C<goto label> statements from working.
 854
 855 =item B<-On>
 856
 857 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
 858 B<-O1> sets B<-fcompress-nullops> B<-fomit-sequence numbers>.
 859 B<-O6> adds B<-fstrip-syntax-tree>.
 860
 861 =item B<-D>
 862
 863 Debug options (concatenated or separate flags like C<perl -D>).
 864
 865 =item B<-Do>
 866
 867 Prints each OP as it's processed.
 868
 869 =item B<-Db>
 870
 871 Print debugging information about bytecompiler progress.
 872
 873 =item B<-Da>
 874
 875 Tells the (bytecode) assembler to include source assembler lines
 876 in its output as bytecode comments.
 877
 878 =item B<-DC>
 879
 880 Prints each CV taken from the final symbol tree walk.
 881
 882 =item B<-S>
 883
 884 Output (bytecode) assembler source rather than piping it
 885 through the assembler and outputting bytecode.
 886
 887 =item B<-m>
 888
 889 Compile as a module rather than a standalone program. Currently this
 890 just means that the bytecodes for initialising C<main_start>,
 891 C<main_root> and C<curpad> are omitted.
 892
 893 =back
 894
 895 =head1 EXAMPLES
 896
 897     perl -MO=Bytecode,-O6,-o,foo.plc foo.pl
 898
 899     perl -MO=Bytecode,-S foo.pl > foo.S
 900     assemble foo.S > foo.plc
 901
 902 Note that C<assemble> lives in the C<B> subdirectory of your perl
 903 library directory. The utility called perlcc may also be used to
 904 help make use of this compiler.
 905
 906     perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm
 907
 908 =head1 BUGS
 909
 910 Plenty. Current status: experimental.
 911
 912 =head1 AUTHOR
 913
 914 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 915
 916 =cut