home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _26d9d0f4c88dc025ac364465ffa9bb91 < prev    next >
Text File  |  2000-03-15  |  24KB  |  920 lines
  1. #      Bytecode.pm
  2. #
  3. #      Copyright (c) 1996-1998 Malcolm Beattie
  4. #
  5. #      You may distribute under the terms of either the GNU General Public
  6. #      License or the Artistic License, as specified in the README file.
  7. #
  8. package B::Bytecode;
  9. use strict;
  10. use Carp;
  11. use IO::File;
  12.  
  13. use B qw(minus_c main_cv main_root main_start comppadlist
  14.      class peekop walkoptree svref_2object cstring walksymtable
  15.      SVf_POK SVp_POK SVf_IOK SVp_IOK
  16.     );
  17. use B::Asmdata qw(@optype @specialsv_name);
  18. use B::Assembler qw(assemble_fh);
  19.  
  20. my %optype_enum;
  21. my $i;
  22. for ($i = 0; $i < @optype; $i++) {
  23.     $optype_enum{$optype[$i]} = $i;
  24. }
  25.  
  26. # Following is SVf_POK|SVp_POK
  27. # XXX Shouldn't be hardwired
  28. sub POK () { SVf_POK|SVp_POK }
  29.  
  30. # Following is SVf_IOK|SVp_IOK
  31. # XXX Shouldn't be hardwired
  32. sub IOK () { SVf_IOK|SVp_IOK }
  33.  
  34. my ($verbose, $module_only, $no_assemble, $debug_bc, $debug_cv);
  35. my $assembler_pid;
  36.  
  37. # Optimisation options. On the command line, use hyphens instead of
  38. # underscores for compatibility with gcc-style options. We use
  39. # underscores here because they are OK in (strict) barewords.
  40. my ($strip_syntree, $compress_nullops, $omit_seq, $bypass_nullops);
  41. my %optimise = (strip_syntax_tree    => \$strip_syntree,
  42.         compress_nullops    => \$compress_nullops,
  43.         omit_sequence_numbers    => \$omit_seq,
  44.         bypass_nullops        => \$bypass_nullops);
  45.  
  46. my $nextix = 0;
  47. my %symtable;    # maps object addresses to object indices.
  48.         # Filled in at allocation (newsv/newop) time.
  49. my %saved;    # maps object addresses (for SVish classes) to "saved yet?"
  50.         # flag. Set at FOO::bytecode time usually by SV::bytecode.
  51.         # Manipulated via saved(), mark_saved(), unmark_saved().
  52.  
  53. my $svix = -1;    # we keep track of when the sv register contains an element
  54.         # of the object table to avoid unnecessary repeated
  55.         # consecutive ldsv instructions.
  56. my $opix = -1;    # Ditto for the op register.
  57.  
  58. sub ldsv {
  59.     my $ix = shift;
  60.     if ($ix != $svix) {
  61.     print "ldsv $ix\n";
  62.     $svix = $ix;
  63.     }
  64. }
  65.  
  66. sub stsv {
  67.     my $ix = shift;
  68.     print "stsv $ix\n";
  69.     $svix = $ix;
  70. }
  71.  
  72. sub set_svix {
  73.     $svix = shift;
  74. }
  75.  
  76. sub ldop {
  77.     my $ix = shift;
  78.     if ($ix != $opix) {
  79.     print "ldop $ix\n";
  80.     $opix = $ix;
  81.     }
  82. }
  83.  
  84. sub stop {
  85.     my $ix = shift;
  86.     print "stop $ix\n";
  87.     $opix = $ix;
  88. }
  89.  
  90. sub set_opix {
  91.     $opix = shift;
  92. }
  93.  
  94. sub pvstring {
  95.     my $str = shift;
  96.     if (defined($str)) {
  97.     return cstring($str . "\0");
  98.     } else {
  99.     return '""';
  100.     }
  101. }
  102.  
  103. sub saved { $saved{${$_[0]}} }
  104. sub mark_saved { $saved{${$_[0]}} = 1 }
  105. sub unmark_saved { $saved{${$_[0]}} = 0 }
  106.  
  107. sub debug { $debug_bc = shift }
  108.  
  109. sub B::OBJECT::nyi {
  110.     my $obj = shift;
  111.     warn sprintf("bytecode save method for %s (0x%x) not yet implemented\n",
  112.          class($obj), $$obj);
  113. }
  114.  
  115. #
  116. # objix may stomp on the op register (for op objects)
  117. # or the sv register (for SV objects)
  118. #
  119. sub B::OBJECT::objix {
  120.     my $obj = shift;
  121.     my $ix = $symtable{$$obj};
  122.     if (defined($ix)) {
  123.     return $ix;
  124.     } else {
  125.     $obj->newix($nextix);
  126.     return $symtable{$$obj} = $nextix++;
  127.     }
  128. }
  129.  
  130. sub B::SV::newix {
  131.     my ($sv, $ix) = @_;
  132.     printf "newsv %d\t# %s\n", $sv->FLAGS & 0xf, class($sv);
  133.     stsv($ix);    
  134. }
  135.  
  136. sub B::GV::newix {
  137.     my ($gv, $ix) = @_;
  138.     my $gvname = $gv->NAME;
  139.     my $name = cstring($gv->STASH->NAME . "::" . $gvname);
  140.     print "gv_fetchpv $name\n";
  141.     stsv($ix);
  142. }
  143.  
  144. sub B::HV::newix {
  145.     my ($hv, $ix) = @_;
  146.     my $name = $hv->NAME;
  147.     if ($name) {
  148.     # It's a stash
  149.     printf "gv_stashpv %s\n", cstring($name);
  150.     stsv($ix);
  151.     } else {
  152.     # It's an ordinary HV. Fall back to ordinary newix method
  153.     $hv->B::SV::newix($ix);
  154.     }
  155. }
  156.  
  157. sub B::SPECIAL::newix {
  158.     my ($sv, $ix) = @_;
  159.     # Special case. $$sv is not the address of the SV but an
  160.     # index into svspecialsv_list.
  161.     printf "ldspecsv $$sv\t# %s\n", $specialsv_name[$$sv];
  162.     stsv($ix);
  163. }
  164.  
  165. sub B::OP::newix {
  166.     my ($op, $ix) = @_;
  167.     my $class = class($op);
  168.     my $typenum = $optype_enum{$class};
  169.     croak "OP::newix: can't understand class $class" unless defined($typenum);
  170.     print "newop $typenum\t# $class\n";
  171.     stop($ix);
  172. }
  173.  
  174. sub B::OP::walkoptree_debug {
  175.     my $op = shift;
  176.     warn(sprintf("walkoptree: %s\n", peekop($op)));
  177. }
  178.  
  179. sub B::OP::bytecode {
  180.     my $op = shift;
  181.     my $next = $op->next;
  182.     my $nextix;
  183.     my $sibix = $op->sibling->objix;
  184.     my $ix = $op->objix;
  185.     my $type = $op->type;
  186.  
  187.     if ($bypass_nullops) {
  188.     $next = $next->next while $$next && $next->type == 0;
  189.     }
  190.     $nextix = $next->objix;
  191.  
  192.     printf "# %s\n", peekop($op) if $debug_bc;
  193.     ldop($ix);
  194.     print "op_next $nextix\n";
  195.     print "op_sibling $sibix\n" unless $strip_syntree;
  196.     printf "op_type %s\t# %d\n", "pp_" . $op->name, $type;
  197.     printf("op_seq %d\n", $op->seq) unless $omit_seq;
  198.     if ($type || !$compress_nullops) {
  199.     printf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n",
  200.         $op->targ, $op->flags, $op->private;
  201.     }
  202. }
  203.  
  204. sub B::UNOP::bytecode {
  205.     my $op = shift;
  206.     my $firstix = $op->first->objix;
  207.     $op->B::OP::bytecode;
  208.     if (($op->type || !$compress_nullops) && !$strip_syntree) {
  209.     print "op_first $firstix\n";
  210.     }
  211. }
  212.  
  213. sub B::LOGOP::bytecode {
  214.     my $op = shift;
  215.     my $otherix = $op->other->objix;
  216.     $op->B::UNOP::bytecode;
  217.     print "op_other $otherix\n";
  218. }
  219.  
  220. sub B::SVOP::bytecode {
  221.     my $op = shift;
  222.     my $sv = $op->sv;
  223.     my $svix = $sv->objix;
  224.     $op->B::OP::bytecode;
  225.     print "op_sv $svix\n";
  226.     $sv->bytecode;
  227. }
  228.  
  229. sub B::PADOP::bytecode {
  230.     my $op = shift;
  231.     my $padix = $op->padix;
  232.     $op->B::OP::bytecode;
  233.     print "op_padix $padix\n";
  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->name eq "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::LISTOP::bytecode {
  262.     my $op = shift;
  263.     my $children = $op->children;
  264.     $op->B::BINOP::bytecode;
  265.     if (($op->type || !$compress_nullops) && !$strip_syntree) {
  266.     print "op_children $children\n";
  267.     }
  268. }
  269.  
  270. sub B::LOOP::bytecode {
  271.     my $op = shift;
  272.     my $redoopix = $op->redoop->objix;
  273.     my $nextopix = $op->nextop->objix;
  274.     my $lastopix = $op->lastop->objix;
  275.     $op->B::LISTOP::bytecode;
  276.     print "op_redoop $redoopix\nop_nextop $nextopix\nop_lastop $lastopix\n";
  277. }
  278.  
  279. sub B::COP::bytecode {
  280.     my $op = shift;
  281.     my $stashpv = $op->stashpv;
  282.     my $file = $op->file;
  283.     my $line = $op->line;
  284.     my $warnings = $op->warnings;
  285.     my $warningsix = $warnings->objix;
  286.     if ($debug_bc) {
  287.     printf "# line %s:%d\n", $file, $line;
  288.     }
  289.     $op->B::OP::bytecode;
  290.     printf <<"EOT", pvstring($op->label), pvstring($stashpv), $op->cop_seq, pvstring($file), $op->arybase;
  291. newpv %s
  292. cop_label
  293. newpv %s
  294. cop_stashpv
  295. cop_seq %d
  296. newpv %s
  297. cop_file
  298. cop_arybase %d
  299. cop_line $line
  300. cop_warnings $warningsix
  301. EOT
  302. }
  303.  
  304. sub B::PMOP::bytecode {
  305.     my $op = shift;
  306.     my $replroot = $op->pmreplroot;
  307.     my $replrootix = $replroot->objix;
  308.     my $replstartix = $op->pmreplstart->objix;
  309.     my $opname = $op->name;
  310.     # pmnext is corrupt in some PMOPs (see misc.t for example)
  311.     #my $pmnextix = $op->pmnext->objix;
  312.  
  313.     if ($$replroot) {
  314.     # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
  315.     # argument to a split) stores a GV in op_pmreplroot instead
  316.     # of a substitution syntax tree. We don't want to walk that...
  317.     if ($opname eq "pushre") {
  318.         $replroot->bytecode;
  319.     } else {
  320.         walkoptree($replroot, "bytecode");
  321.     }
  322.     }
  323.     $op->B::LISTOP::bytecode;
  324.     if ($opname eq "pushre") {
  325.     printf "op_pmreplrootgv $replrootix\n";
  326.     } else {
  327.     print "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n";
  328.     }
  329.     my $re = pvstring($op->precomp);
  330.     # op_pmnext omitted since a perl bug means it's sometime corrupt
  331.     printf <<"EOT", $op->pmflags, $op->pmpermflags;
  332. op_pmflags 0x%x
  333. op_pmpermflags 0x%x
  334. newpv $re
  335. pregcomp
  336. EOT
  337. }
  338.  
  339. sub B::SV::bytecode {
  340.     my $sv = shift;
  341.     return if saved($sv);
  342.     my $ix = $sv->objix;
  343.     my $refcnt = $sv->REFCNT;
  344.     my $flags = sprintf("0x%x", $sv->FLAGS);
  345.     ldsv($ix);
  346.     print "sv_refcnt $refcnt\nsv_flags $flags\n";
  347.     mark_saved($sv);
  348. }
  349.  
  350. sub B::PV::bytecode {
  351.     my $sv = shift;
  352.     return if saved($sv);
  353.     $sv->B::SV::bytecode;
  354.     printf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK;
  355. }
  356.  
  357. sub B::IV::bytecode {
  358.     my $sv = shift;
  359.     return if saved($sv);
  360.     my $iv = $sv->IVX;
  361.     $sv->B::SV::bytecode;
  362.     printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32";
  363. }
  364.  
  365. sub B::NV::bytecode {
  366.     my $sv = shift;
  367.     return if saved($sv);
  368.     $sv->B::SV::bytecode;
  369.     printf "xnv %s\n", $sv->NVX;
  370. }
  371.  
  372. sub B::RV::bytecode {
  373.     my $sv = shift;
  374.     return if saved($sv);
  375.     my $rv = $sv->RV;
  376.     my $rvix = $rv->objix;
  377.     $rv->bytecode;
  378.     $sv->B::SV::bytecode;
  379.     print "xrv $rvix\n";
  380. }
  381.  
  382. sub B::PVIV::bytecode {
  383.     my $sv = shift;
  384.     return if saved($sv);
  385.     my $iv = $sv->IVX;
  386.     $sv->B::PV::bytecode;
  387.     printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32";
  388. }
  389.  
  390. sub B::PVNV::bytecode {
  391.     my $sv = shift;
  392.     my $flag = shift || 0;
  393.     # The $flag argument is passed through PVMG::bytecode by BM::bytecode
  394.     # and AV::bytecode and indicates special handling. $flag = 1 is used by
  395.     # BM::bytecode and means that we should ensure we save the whole B-M
  396.     # table. It consists of 257 bytes (256 char array plus a final \0)
  397.     # which follow the ordinary PV+\0 and the 257 bytes are *not* reflected
  398.     # in SvCUR. $flag = 2 is used by AV::bytecode and means that we only
  399.     # call SV::bytecode instead of saving PV and calling NV::bytecode since
  400.     # PV/NV/IV stuff is different for AVs.
  401.     return if saved($sv);
  402.     if ($flag == 2) {
  403.     $sv->B::SV::bytecode;
  404.     } else {
  405.     my $pv = $sv->PV;
  406.     $sv->B::IV::bytecode;
  407.     printf "xnv %s\n", $sv->NVX;
  408.     if ($flag == 1) {
  409.         $pv .= "\0" . $sv->TABLE;
  410.         printf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257;
  411.     } else {
  412.         printf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK;
  413.     }
  414.     }
  415. }
  416.  
  417. sub B::PVMG::bytecode {
  418.     my ($sv, $flag) = @_;
  419.     # See B::PVNV::bytecode for an explanation of $flag.
  420.     return if saved($sv);
  421.     # XXX We assume SvSTASH is already saved and don't save it later ourselves
  422.     my $stashix = $sv->SvSTASH->objix;
  423.     my @mgchain = $sv->MAGIC;
  424.     my (@mgobjix, $mg);
  425.     #
  426.     # We need to traverse the magic chain and get objix for each OBJ
  427.     # field *before* we do B::PVNV::bytecode since objix overwrites
  428.     # the sv register. However, we need to write the magic-saving
  429.     # bytecode *after* B::PVNV::bytecode since sv isn't initialised
  430.     # to refer to $sv until then.
  431.     #
  432.     @mgobjix = map($_->OBJ->objix, @mgchain);
  433.     $sv->B::PVNV::bytecode($flag);
  434.     print "xmg_stash $stashix\n";
  435.     foreach $mg (@mgchain) {
  436.     printf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n",
  437.         cstring($mg->TYPE), shift(@mgobjix), pvstring($mg->PTR);
  438.     }
  439. }
  440.  
  441. sub B::PVLV::bytecode {
  442.     my $sv = shift;
  443.     return if saved($sv);
  444.     $sv->B::PVMG::bytecode;
  445.     printf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE);
  446. xlv_targoff %d
  447. xlv_targlen %d
  448. xlv_type %s
  449. EOT
  450. }
  451.  
  452. sub B::BM::bytecode {
  453.     my $sv = shift;
  454.     return if saved($sv);
  455.     # See PVNV::bytecode for an explanation of what the argument does
  456.     $sv->B::PVMG::bytecode(1);
  457.     printf "xbm_useful %d\nxbm_previous %d\nxbm_rare %d\n",
  458.     $sv->USEFUL, $sv->PREVIOUS, $sv->RARE;
  459. }
  460.  
  461. sub B::GV::bytecode {
  462.     my $gv = shift;
  463.     return if saved($gv);
  464.     my $ix = $gv->objix;
  465.     mark_saved($gv);
  466.     ldsv($ix);
  467.     printf <<"EOT", $gv->FLAGS, $gv->GvFLAGS;
  468. sv_flags 0x%x
  469. xgv_flags 0x%x
  470. EOT
  471.     my $refcnt = $gv->REFCNT;
  472.     printf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1;
  473.     return if $gv->is_empty;
  474.     printf <<"EOT", $gv->LINE, pvstring($gv->FILE);
  475. gp_line %d
  476. newpv %s
  477. gp_file
  478. EOT
  479.     my $gvname = $gv->NAME;
  480.     my $name = cstring($gv->STASH->NAME . "::" . $gvname);
  481.     my $egv = $gv->EGV;
  482.     my $egvix = $egv->objix;
  483.     my $gvrefcnt = $gv->GvREFCNT;
  484.     printf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1;
  485.     if ($gvrefcnt > 1 &&  $ix != $egvix) {
  486.     print "gp_share $egvix\n";
  487.     } else {
  488.     if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
  489.         my $i;
  490.         my @subfield_names = qw(SV AV HV CV FORM IO);
  491.         my @subfields = map($gv->$_(), @subfield_names);
  492.         my @ixes = map($_->objix, @subfields);
  493.         # Reset sv register for $gv
  494.         ldsv($ix);
  495.         for ($i = 0; $i < @ixes; $i++) {
  496.         printf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
  497.         }
  498.         # Now save all the subfields
  499.         my $sv;
  500.         foreach $sv (@subfields) {
  501.         $sv->bytecode;
  502.         }
  503.     }
  504.     }
  505. }
  506.  
  507. sub B::HV::bytecode {
  508.     my $hv = shift;
  509.     return if saved($hv);
  510.     mark_saved($hv);
  511.     my $name = $hv->NAME;
  512.     my $ix = $hv->objix;
  513.     if (!$name) {
  514.     # It's an ordinary HV. Stashes have NAME set and need no further
  515.     # saving beyond the gv_stashpv that $hv->objix already ensures.
  516.     my @contents = $hv->ARRAY;
  517.     my ($i, @ixes);
  518.     for ($i = 1; $i < @contents; $i += 2) {
  519.         push(@ixes, $contents[$i]->objix);
  520.     }
  521.     for ($i = 1; $i < @contents; $i += 2) {
  522.         $contents[$i]->bytecode;
  523.     }
  524.     ldsv($ix);
  525.     for ($i = 0; $i < @contents; $i += 2) {
  526.         printf("newpv %s\nhv_store %d\n",
  527.            pvstring($contents[$i]), $ixes[$i / 2]);
  528.     }
  529.     printf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS;
  530.     }
  531. }
  532.  
  533. sub B::AV::bytecode {
  534.     my $av = shift;
  535.     return if saved($av);
  536.     my $ix = $av->objix;
  537.     my $fill = $av->FILL;
  538.     my $max = $av->MAX;
  539.     my (@array, @ixes);
  540.     if ($fill > -1) {
  541.     @array = $av->ARRAY;
  542.     @ixes = map($_->objix, @array);
  543.     my $sv;
  544.     foreach $sv (@array) {
  545.         $sv->bytecode;
  546.     }
  547.     }
  548.     # See PVNV::bytecode for the meaning of the flag argument of 2.
  549.     $av->B::PVMG::bytecode(2);
  550.     # Recover sv register and set AvMAX and AvFILL to -1 (since we
  551.     # create an AV with NEWSV and SvUPGRADE rather than doing newAV
  552.     # which is what sets AvMAX and AvFILL.
  553.     ldsv($ix);
  554.     printf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS;
  555.     if ($fill > -1) {
  556.     my $elix;
  557.     foreach $elix (@ixes) {
  558.         print "av_push $elix\n";
  559.     }
  560.     } else {
  561.     if ($max > -1) {
  562.         print "av_extend $max\n";
  563.     }
  564.     }
  565. }
  566.  
  567. sub B::CV::bytecode {
  568.     my $cv = shift;
  569.     return if saved($cv);
  570.     my $ix = $cv->objix;
  571.     $cv->B::PVMG::bytecode;
  572.     my $i;
  573.     my @subfield_names = qw(ROOT START STASH GV PADLIST OUTSIDE);
  574.     my @subfields = map($cv->$_(), @subfield_names);
  575.     my @ixes = map($_->objix, @subfields);
  576.     # Save OP tree from CvROOT (first element of @subfields)
  577.     my $root = shift @subfields;
  578.     if ($$root) {
  579.     walkoptree($root, "bytecode");
  580.     }
  581.     # Reset sv register for $cv (since above ->objix calls stomped on it)
  582.     ldsv($ix);
  583.     for ($i = 0; $i < @ixes; $i++) {
  584.     printf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
  585.     }
  586.     printf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->CvFLAGS;
  587.     printf "newpv %s\nxcv_file\n", pvstring($cv->FILE);
  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 XSLoader 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 "a") {
  711.         $arg ||= shift @options;
  712.         open(OUT, ">>$arg") or return "$arg: $!\n";
  713.         binmode OUT;
  714.     } elsif ($opt eq "D") {
  715.         $arg ||= shift @options;
  716.         foreach $arg (split(//, $arg)) {
  717.         if ($arg eq "b") {
  718.             $| = 1;
  719.             debug(1);
  720.         } elsif ($arg eq "o") {
  721.             B->debug(1);
  722.         } elsif ($arg eq "a") {
  723.             B::Assembler::debug(1);
  724.         } elsif ($arg eq "C") {
  725.             $debug_cv = 1;
  726.         }
  727.         }
  728.     } elsif ($opt eq "v") {
  729.         $verbose = 1;
  730.     } elsif ($opt eq "m") {
  731.         $module_only = 1;
  732.     } elsif ($opt eq "S") {
  733.         $no_assemble = 1;
  734.     } elsif ($opt eq "f") {
  735.         $arg ||= shift @options;
  736.         my $value = $arg !~ s/^no-//;
  737.         $arg =~ s/-/_/g;
  738.         my $ref = $optimise{$arg};
  739.         if (defined($ref)) {
  740.         $$ref = $value;
  741.         } else {
  742.         warn qq(ignoring unknown optimisation option "$arg"\n);
  743.         }
  744.     } elsif ($opt eq "O") {
  745.         $arg = 1 if $arg eq "";
  746.         my $ref;
  747.         foreach $ref (values %optimise) {
  748.         $$ref = 0;
  749.         }
  750.         if ($arg >= 6) {
  751.         $strip_syntree = 1;
  752.         }
  753.         if ($arg >= 2) {
  754.         $bypass_nullops = 1;
  755.         }
  756.         if ($arg >= 1) {
  757.         $compress_nullops = 1;
  758.         $omit_seq = 1;
  759.         }
  760.     }
  761.     }
  762.     if (@options) {
  763.     return sub {
  764.         my $objname;
  765.         my $newfh; 
  766.         $newfh = prepare_assemble() unless $no_assemble;
  767.         foreach $objname (@options) {
  768.         eval "bytecompile_object(\\$objname)";
  769.         }
  770.         do_assemble($newfh) unless $no_assemble;
  771.     }
  772.     } else {
  773.     return sub {
  774.         my $newfh; 
  775.         $newfh = prepare_assemble() unless $no_assemble;
  776.         bytecompile_main();
  777.         do_assemble($newfh) unless $no_assemble;
  778.     }
  779.     }
  780. }
  781.  
  782. 1;
  783.  
  784. __END__
  785.  
  786. =head1 NAME
  787.  
  788. B::Bytecode - Perl compiler's bytecode backend
  789.  
  790. =head1 SYNOPSIS
  791.  
  792.     perl -MO=Bytecode[,OPTIONS] foo.pl
  793.  
  794. =head1 DESCRIPTION
  795.  
  796. This compiler backend takes Perl source and generates a
  797. platform-independent bytecode encapsulating code to load the
  798. internal structures perl uses to run your program. When the
  799. generated bytecode is loaded in, your program is ready to run,
  800. reducing the time which perl would have taken to load and parse
  801. your program into its internal semi-compiled form. That means that
  802. compiling with this backend will not help improve the runtime
  803. execution speed of your program but may improve the start-up time.
  804. Depending on the environment in which your program runs this may
  805. or may not be a help.
  806.  
  807. The resulting bytecode can be run with a special byteperl executable
  808. or (for non-main programs) be loaded via the C<byteload_fh> function
  809. in the F<B> module.
  810.  
  811. =head1 OPTIONS
  812.  
  813. If there are any non-option arguments, they are taken to be names of
  814. objects to be saved (probably doesn't work properly yet).  Without
  815. extra arguments, it saves the main program.
  816.  
  817. =over 4
  818.  
  819. =item B<-ofilename>
  820.  
  821. Output to filename instead of STDOUT.
  822.  
  823. =item B<-afilename>
  824.  
  825. Append output to filename.
  826.  
  827. =item B<-->
  828.  
  829. Force end of options.
  830.  
  831. =item B<-f>
  832.  
  833. Force optimisations on or off one at a time. Each can be preceded
  834. by B<no-> to turn the option off (e.g. B<-fno-compress-nullops>).
  835.  
  836. =item B<-fcompress-nullops>
  837.  
  838. Only fills in the necessary fields of ops which have
  839. been optimised away by perl's internal compiler.
  840.  
  841. =item B<-fomit-sequence-numbers>
  842.  
  843. Leaves out code to fill in the op_seq field of all ops
  844. which is only used by perl's internal compiler.
  845.  
  846. =item B<-fbypass-nullops>
  847.  
  848. If op->op_next ever points to a NULLOP, replaces the op_next field
  849. with the first non-NULLOP in the path of execution.
  850.  
  851. =item B<-fstrip-syntax-tree>
  852.  
  853. Leaves out code to fill in the pointers which link the internal syntax
  854. tree together. They're not needed at run-time but leaving them out
  855. will make it impossible to recompile or disassemble the resulting
  856. program.  It will also stop C<goto label> statements from working.
  857.  
  858. =item B<-On>
  859.  
  860. Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
  861. B<-O1> sets B<-fcompress-nullops> B<-fomit-sequence numbers>.
  862. B<-O6> adds B<-fstrip-syntax-tree>.
  863.  
  864. =item B<-D>
  865.  
  866. Debug options (concatenated or separate flags like C<perl -D>).
  867.  
  868. =item B<-Do>
  869.  
  870. Prints each OP as it's processed.
  871.  
  872. =item B<-Db>
  873.  
  874. Print debugging information about bytecompiler progress.
  875.  
  876. =item B<-Da>
  877.  
  878. Tells the (bytecode) assembler to include source assembler lines
  879. in its output as bytecode comments.
  880.  
  881. =item B<-DC>
  882.  
  883. Prints each CV taken from the final symbol tree walk.
  884.  
  885. =item B<-S>
  886.  
  887. Output (bytecode) assembler source rather than piping it
  888. through the assembler and outputting bytecode.
  889.  
  890. =item B<-m>
  891.  
  892. Compile as a module rather than a standalone program. Currently this
  893. just means that the bytecodes for initialising C<main_start>,
  894. C<main_root> and C<curpad> are omitted.
  895.  
  896. =back
  897.  
  898. =head1 EXAMPLES
  899.  
  900.     perl -MO=Bytecode,-O6,-o,foo.plc foo.pl
  901.  
  902.     perl -MO=Bytecode,-S foo.pl > foo.S
  903.     assemble foo.S > foo.plc
  904.  
  905. Note that C<assemble> lives in the C<B> subdirectory of your perl
  906. library directory. The utility called perlcc may also be used to 
  907. help make use of this compiler.
  908.  
  909.     perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm
  910.  
  911. =head1 BUGS
  912.  
  913. Plenty. Current status: experimental.
  914.  
  915. =head1 AUTHOR
  916.  
  917. Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
  918.  
  919. =cut
  920.