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