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