ext/B/B/Bytecode.pm

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