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