home *** CD-ROM | disk | FTP | other *** search
/ PC World 2005 June / PCWorld_2005-06_cd.bin / software / vyzkuste / firewally / firewally.exe / framework-2.3.exe / Bytecode.pm < prev    next >
Text File  |  2003-11-07  |  20KB  |  872 lines
  1. # B::Bytecode.pm
  2. # Copyright (c) 2003 Enache Adrian. All rights reserved.
  3. # This module is free software; you can redistribute and/or modify
  4. # it under the same terms as Perl itself.
  5.  
  6. # Based on the original Bytecode.pm module written by Malcolm Beattie.
  7.  
  8. package B::Bytecode;
  9.  
  10. our $VERSION = '1.01';
  11.  
  12. use strict;
  13. use Config;
  14. use B qw(class main_cv main_root main_start cstring comppadlist
  15.     defstash curstash begin_av init_av end_av inc_gv warnhook diehook
  16.     dowarn SVt_PVGV SVt_PVHV OPf_SPECIAL OPf_STACKED OPf_MOD
  17.     OPpLVAL_INTRO SVf_FAKE SVf_READONLY);
  18. use B::Asmdata qw(@specialsv_name);
  19. use B::Assembler qw(asm newasm endasm);
  20.  
  21. #################################################
  22.  
  23. my ($varix, $opix, $savebegins, %walked, %files, @cloop);
  24. my %strtab = (0,0);
  25. my %svtab = (0,0);
  26. my %optab = (0,0);
  27. my %spectab = (0,0);
  28. my $tix = 1;
  29. sub asm;
  30. sub nice ($) { }
  31.  
  32. BEGIN {
  33.     my $ithreads = $Config{'useithreads'} eq 'define';
  34.     eval qq{
  35.     sub ITHREADS() { $ithreads }
  36.     sub VERSION() { $] }
  37.     }; die $@ if $@;
  38. }
  39.  
  40. #################################################
  41.  
  42. sub pvstring {
  43.     my $pv = shift;
  44.     defined($pv) ? cstring ($pv."\0") : "\"\"";
  45. }
  46.  
  47. sub pvix {
  48.     my $str = pvstring shift;
  49.     my $ix = $strtab{$str};
  50.     defined($ix) ? $ix : do {
  51.     asm "newpv", $str;
  52.     asm "stpv", $strtab{$str} = $tix;
  53.     $tix++;
  54.     }
  55. }
  56.  
  57. sub B::OP::ix {
  58.     my $op = shift;
  59.     my $ix = $optab{$$op};
  60.     defined($ix) ? $ix : do {
  61.     nice "[".$op->name." $tix]";
  62.     asm "newopx", $op->size | $op->type <<7;
  63.     $optab{$$op} = $opix = $ix = $tix++;
  64.     $op->bsave($ix);
  65.     $ix;
  66.     }
  67. }
  68.  
  69. sub B::SPECIAL::ix {
  70.     my $spec = shift;
  71.     my $ix = $spectab{$$spec};
  72.     defined($ix) ? $ix : do {
  73.     nice '['.$specialsv_name[$$spec].']';
  74.     asm "ldspecsvx", $$spec;
  75.     $spectab{$$spec} = $varix = $tix++;
  76.     }
  77. }
  78.  
  79. sub B::SV::ix {
  80.     my $sv = shift;
  81.     my $ix = $svtab{$$sv};
  82.     defined($ix) ? $ix : do {
  83.     nice '['.class($sv).']';
  84.     asm "newsvx", $sv->FLAGS;
  85.     $svtab{$$sv} = $varix = $ix = $tix++;
  86.     $sv->bsave($ix);
  87.     $ix;
  88.     }
  89. }
  90.  
  91. sub B::GV::ix {
  92.     my ($gv,$desired) = @_;
  93.     my $ix = $svtab{$$gv};
  94.     defined($ix) ? $ix : do {
  95.     if ($gv->GP) {
  96.         my ($svix, $avix, $hvix, $cvix, $ioix, $formix);
  97.         nice "[GV]";
  98.         my $name = $gv->STASH->NAME . "::" . $gv->NAME;
  99.         asm "gv_fetchpvx", cstring $name;
  100.         $svtab{$$gv} = $varix = $ix = $tix++;
  101.         asm "sv_flags", $gv->FLAGS;
  102.         asm "sv_refcnt", $gv->REFCNT;
  103.         asm "xgv_flags", $gv->GvFLAGS;
  104.  
  105.         asm "gp_refcnt", $gv->GvREFCNT;
  106.         asm "load_glob", $ix if $name eq "CORE::GLOBAL::glob";
  107.         return $ix
  108.             unless $desired || desired $gv;
  109.         $svix = $gv->SV->ix;
  110.         $avix = $gv->AV->ix;
  111.         $hvix = $gv->HV->ix;
  112.  
  113.     # XXX {{{{
  114.         my $cv = $gv->CV;
  115.         $cvix = $$cv && defined $files{$cv->FILE} ? $cv->ix : 0;
  116.         my $form = $gv->FORM;
  117.         $formix = $$form && defined $files{$form->FILE} ? $form->ix : 0;
  118.  
  119.         $ioix = $name !~ /STDOUT$/ ? $gv->IO->ix : 0;    
  120.                                 # }}}} XXX
  121.  
  122.         nice "-GV-",
  123.         asm "ldsv", $varix = $ix unless $ix == $varix;
  124.         asm "gp_sv", $svix;
  125.         asm "gp_av", $avix;
  126.         asm "gp_hv", $hvix;
  127.         asm "gp_cv", $cvix;
  128.         asm "gp_io", $ioix;
  129.         asm "gp_cvgen", $gv->CVGEN;
  130.         asm "gp_form", $formix;
  131.         asm "gp_file", pvix $gv->FILE;
  132.         asm "gp_line", $gv->LINE;
  133.         asm "formfeed", $svix if $name eq "main::\cL";
  134.     } else {
  135.         nice "[GV]";
  136.         asm "newsvx", $gv->FLAGS;
  137.         $svtab{$$gv} = $varix = $ix = $tix++;
  138.         my $stashix = $gv->STASH->ix;
  139.         $gv->B::PVMG::bsave($ix);
  140.         asm "xgv_flags", $gv->GvFLAGS;
  141.         asm "xgv_stash", $stashix;
  142.     }
  143.     $ix;
  144.     }
  145. }
  146.  
  147. sub B::HV::ix {
  148.     my $hv = shift;
  149.     my $ix = $svtab{$$hv};
  150.     defined($ix) ? $ix : do {
  151.     my ($ix,$i,@array);
  152.     my $name = $hv->NAME;
  153.     if ($name) {
  154.         nice "[STASH]";
  155.         asm "gv_stashpvx", cstring $name;
  156.         asm "sv_flags", $hv->FLAGS;
  157.         $svtab{$$hv} = $varix = $ix = $tix++;
  158.         asm "xhv_name", pvix $name;
  159.         # my $pmrootix = $hv->PMROOT->ix;    # XXX
  160.         asm "ldsv", $varix = $ix unless $ix == $varix;
  161.         # asm "xhv_pmroot", $pmrootix;    # XXX
  162.     } else {
  163.         nice "[HV]";
  164.         asm "newsvx", $hv->FLAGS;
  165.         $svtab{$$hv} = $varix = $ix = $tix++;
  166.         my $stashix = $hv->SvSTASH->ix;
  167.         for (@array = $hv->ARRAY) {
  168.         next if $i = not $i;
  169.         $_ = $_->ix;
  170.         }
  171.         nice "-HV-",
  172.         asm "ldsv", $varix = $ix unless $ix == $varix;
  173.         ($i = not $i) ? asm ("newpv", pvstring $_) : asm("hv_store", $_)
  174.         for @array;
  175.         asm "xnv", $hv->NVX;
  176.         asm "xmg_stash", $stashix;
  177.         asm "xhv_riter", $hv->RITER;
  178.     }
  179.     asm "sv_refcnt", $hv->REFCNT;
  180.     $ix;
  181.     }
  182. }
  183.  
  184. sub B::NULL::ix {
  185.     my $sv = shift;
  186.     $$sv ? $sv->B::SV::ix : 0;
  187. }
  188.  
  189. sub B::NULL::opwalk { 0 }
  190.  
  191. #################################################
  192.  
  193. sub B::NULL::bsave {
  194.     my ($sv,$ix) = @_;
  195.  
  196.     nice '-'.class($sv).'-',
  197.     asm "ldsv", $varix = $ix unless $ix == $varix;
  198.     asm "sv_refcnt", $sv->REFCNT;
  199. }
  200.  
  201. sub B::SV::bsave;
  202.     *B::SV::bsave = *B::NULL::bsave;
  203.  
  204. sub B::RV::bsave {
  205.     my ($sv,$ix) = @_;
  206.     my $rvix = $sv->RV->ix;
  207.     $sv->B::NULL::bsave($ix);
  208.     asm "xrv", $rvix;
  209. }
  210.  
  211. sub B::PV::bsave {
  212.     my ($sv,$ix) = @_;
  213.     $sv->B::NULL::bsave($ix);
  214.     asm "newpv", pvstring $sv->PVBM;
  215.     asm "xpv";
  216. }
  217.  
  218. sub B::IV::bsave {
  219.     my ($sv,$ix) = @_;
  220.     $sv->B::NULL::bsave($ix);
  221.     asm "xiv", $sv->IVX;
  222. }
  223.  
  224. sub B::NV::bsave {
  225.     my ($sv,$ix) = @_;
  226.     $sv->B::NULL::bsave($ix);
  227.     asm "xnv", sprintf "%.40g", $sv->NVX;
  228. }
  229.  
  230. sub B::PVIV::bsave {
  231.     my ($sv,$ix) = @_;
  232.     $sv->POK ?
  233.     $sv->B::PV::bsave($ix):
  234.     $sv->ROK ?
  235.     $sv->B::RV::bsave($ix):
  236.     $sv->B::NULL::bsave($ix);
  237.     asm "xiv", !ITHREADS && $sv->FLAGS & (SVf_FAKE|SVf_READONLY) ?
  238.     "0 but true" : $sv->IVX;
  239. }
  240.  
  241. sub B::PVNV::bsave {
  242.     my ($sv,$ix) = @_;
  243.     $sv->B::PVIV::bsave($ix);
  244.     asm "xnv", sprintf "%.40g", $sv->NVX;
  245. }
  246.  
  247. sub B::PVMG::domagic {
  248.     my ($sv,$ix) = @_;
  249.     nice '-MAGICAL-';
  250.     my @mglist = $sv->MAGIC;
  251.     my (@mgix, @namix);
  252.     for (@mglist) {
  253.     push @mgix, $_->OBJ->ix;
  254.     push @namix, $_->PTR->ix if $_->LENGTH == B::HEf_SVKEY;
  255.     }
  256.  
  257.     nice '-'.class($sv).'-',
  258.     asm "ldsv", $varix = $ix unless $ix == $varix;
  259.     for (@mglist) {
  260.     asm "sv_magic", cstring $_->TYPE;
  261.     asm "mg_obj", shift @mgix;
  262.     my $length = $_->LENGTH;
  263.     if ($length == B::HEf_SVKEY) {
  264.         asm "mg_namex", shift @namix;
  265.     } elsif ($length) {
  266.         asm "newpv", pvstring $_->PTR;
  267.         asm "mg_name";
  268.     }
  269.     }
  270. }
  271.  
  272. sub B::PVMG::bsave {
  273.     my ($sv,$ix) = @_;
  274.     my $stashix = $sv->SvSTASH->ix;
  275.     $sv->B::PVNV::bsave($ix);
  276.     asm "xmg_stash", $stashix;
  277.     $sv->domagic($ix) if $sv->MAGICAL;
  278. }
  279.  
  280. sub B::PVLV::bsave {
  281.     my ($sv,$ix) = @_;
  282.     my $targix = $sv->TARG->ix;
  283.     $sv->B::PVMG::bsave($ix);
  284.     asm "xlv_targ", $targix;
  285.     asm "xlv_targoff", $sv->TARGOFF;
  286.     asm "xlv_targlen", $sv->TARGLEN;
  287.     asm "xlv_type", $sv->TYPE;
  288.  
  289. }
  290.  
  291. sub B::BM::bsave {
  292.     my ($sv,$ix) = @_;
  293.     $sv->B::PVMG::bsave($ix);
  294.     asm "xpv_cur", $sv->CUR;
  295.     asm "xbm_useful", $sv->USEFUL;
  296.     asm "xbm_previous", $sv->PREVIOUS;
  297.     asm "xbm_rare", $sv->RARE;
  298. }
  299.  
  300. sub B::IO::bsave {
  301.     my ($io,$ix) = @_;
  302.     my $topix = $io->TOP_GV->ix;
  303.     my $fmtix = $io->FMT_GV->ix;
  304.     my $bottomix = $io->BOTTOM_GV->ix;
  305.     $io->B::PVMG::bsave($ix);
  306.     asm "xio_lines", $io->LINES;
  307.     asm "xio_page", $io->PAGE;
  308.     asm "xio_page_len", $io->PAGE_LEN;
  309.     asm "xio_lines_left", $io->LINES_LEFT;
  310.     asm "xio_top_name", pvix $io->TOP_NAME;
  311.     asm "xio_top_gv", $topix;
  312.     asm "xio_fmt_name", pvix $io->FMT_NAME;
  313.     asm "xio_fmt_gv", $fmtix;
  314.     asm "xio_bottom_name", pvix $io->BOTTOM_NAME;
  315.     asm "xio_bottom_gv", $bottomix;
  316.     asm "xio_subprocess", $io->SUBPROCESS;
  317.     asm "xio_type", ord $io->IoTYPE;
  318.     # asm "xio_flags", ord($io->IoFLAGS) & ~32;        # XXX XXX
  319. }
  320.  
  321. sub B::CV::bsave {
  322.     my ($cv,$ix) = @_;
  323.     my $stashix = $cv->STASH->ix;
  324.     my $gvix = $cv->GV->ix;
  325.     my $padlistix = $cv->PADLIST->ix;
  326.     my $outsideix = $cv->OUTSIDE->ix;
  327.     my $constix = $cv->CONST ? $cv->XSUBANY->ix : 0;
  328.     my $startix = $cv->START->opwalk;
  329.     my $rootix = $cv->ROOT->ix;
  330.  
  331.     $cv->B::PVMG::bsave($ix);
  332.     asm "xcv_stash", $stashix;
  333.     asm "xcv_start", $startix;
  334.     asm "xcv_root", $rootix;
  335.     asm "xcv_xsubany", $constix;
  336.     asm "xcv_gv", $gvix;
  337.     asm "xcv_file", pvix $cv->FILE if $cv->FILE;    # XXX AD
  338.     asm "xcv_padlist", $padlistix;
  339.     asm "xcv_outside", $outsideix;
  340.     asm "xcv_flags", $cv->CvFLAGS;
  341.     asm "xcv_outside_seq", $cv->OUTSIDE_SEQ;
  342.     asm "xcv_depth", $cv->DEPTH;
  343. }
  344.  
  345. sub B::FM::bsave {
  346.     my ($form,$ix) = @_;
  347.  
  348.     $form->B::CV::bsave($ix);
  349.     asm "xfm_lines", $form->LINES;
  350. }
  351.  
  352. sub B::AV::bsave {
  353.     my ($av,$ix) = @_;
  354.     return $av->B::PVMG::bsave($ix) if $av->MAGICAL;
  355.     my @array = $av->ARRAY;
  356.     $_ = $_->ix for @array;
  357.     my $stashix = $av->SvSTASH->ix;
  358.  
  359.     nice "-AV-",
  360.     asm "ldsv", $varix = $ix unless $ix == $varix;
  361.     asm "av_extend", $av->MAX if $av->MAX >= 0;
  362.     asm "av_pushx", $_ for @array;
  363.     asm "sv_refcnt", $av->REFCNT;
  364.     asm "xav_flags", $av->AvFLAGS;
  365.     asm "xmg_stash", $stashix;
  366. }
  367.  
  368. sub B::GV::desired {
  369.     my $gv = shift;
  370.     my ($cv, $form);
  371.     $files{$gv->FILE} && $gv->LINE
  372.     || ${$cv = $gv->CV} && $files{$cv->FILE}
  373.     || ${$form = $gv->FORM} && $files{$form->FILE}
  374. }
  375.  
  376. sub B::HV::bwalk {
  377.     my $hv = shift;
  378.     return if $walked{$$hv}++;
  379.     my %stash = $hv->ARRAY;
  380.     while (my($k,$v) = each %stash) {
  381.     if ($v->SvTYPE == SVt_PVGV) {
  382.         my $hash = $v->HV;
  383.         if ($$hash && $hash->NAME) {
  384.         $hash->bwalk;
  385.         } 
  386.         $v->ix(1) if desired $v;
  387.     } else {
  388.         nice "[prototype]";
  389.         asm "gv_fetchpvx", cstring $hv->NAME . "::$k";
  390.         $svtab{$$v} = $varix = $tix;
  391.         $v->bsave($tix++);
  392.         asm "sv_flags", $v->FLAGS;
  393.     }
  394.     }
  395. }
  396.  
  397. ######################################################
  398.  
  399.  
  400. sub B::OP::bsave_thin {
  401.     my ($op, $ix) = @_;
  402.     my $next = $op->next;
  403.     my $nextix = $optab{$$next};
  404.     $nextix = 0, push @cloop, $op unless defined $nextix;
  405.     if ($ix != $opix) {
  406.     nice '-'.$op->name.'-',
  407.     asm "ldop", $opix = $ix;
  408.     }
  409.     asm "op_next", $nextix;
  410.     asm "op_targ", $op->targ if $op->type;        # tricky
  411.     asm "op_flags", $op->flags;
  412.     asm "op_private", $op->private;
  413. }
  414.  
  415. sub B::OP::bsave;
  416.     *B::OP::bsave = *B::OP::bsave_thin;
  417.  
  418. sub B::UNOP::bsave {
  419.     my ($op, $ix) = @_;
  420.     my $name = $op->name;
  421.     my $flags = $op->flags;
  422.     my $first = $op->first;
  423.     my $firstix = 
  424.     $name =~ /fl[io]p/
  425.             # that's just neat
  426.     ||    (!ITHREADS && $name eq 'regcomp')
  427.             # trick for /$a/o in pp_regcomp
  428.     ||    $name eq 'rv2sv'
  429.         && $op->flags & OPf_MOD    
  430.         && $op->private & OPpLVAL_INTRO
  431.             # change #18774 made my life hard
  432.     ?    $first->ix
  433.     :    0;
  434.  
  435.     $op->B::OP::bsave($ix);
  436.     asm "op_first", $firstix;
  437. }
  438.  
  439. sub B::BINOP::bsave {
  440.     my ($op, $ix) = @_;
  441.     if ($op->name eq 'aassign' && $op->private & B::OPpASSIGN_HASH()) {
  442.     my $last = $op->last;
  443.     my $lastix = do {
  444.         local *B::OP::bsave = *B::OP::bsave_fat;
  445.         local *B::UNOP::bsave = *B::UNOP::bsave_fat;
  446.         $last->ix;
  447.     };
  448.     asm "ldop", $lastix unless $lastix == $opix;
  449.     asm "op_targ", $last->targ;
  450.     $op->B::OP::bsave($ix);
  451.     asm "op_last", $lastix;
  452.     } else {
  453.     $op->B::OP::bsave($ix);
  454.     }
  455. }
  456.  
  457. # not needed if no pseudohashes
  458.  
  459. *B::BINOP::bsave = *B::OP::bsave if VERSION >= 5.009;
  460.  
  461. # deal with sort / formline 
  462.  
  463. sub B::LISTOP::bsave {
  464.     my ($op, $ix) = @_;
  465.     my $name = $op->name;
  466.     sub blocksort() { OPf_SPECIAL|OPf_STACKED }
  467.     if ($name eq 'sort' && ($op->flags & blocksort) == blocksort) {
  468.     my $first = $op->first;
  469.     my $pushmark = $first->sibling;
  470.     my $rvgv = $pushmark->first;
  471.     my $leave = $rvgv->first;
  472.  
  473.     my $leaveix = $leave->ix;
  474.  
  475.     my $rvgvix = $rvgv->ix;
  476.     asm "ldop", $rvgvix unless $rvgvix == $opix;
  477.     asm "op_first", $leaveix;
  478.  
  479.     my $pushmarkix = $pushmark->ix;
  480.     asm "ldop", $pushmarkix unless $pushmarkix == $opix;
  481.     asm "op_first", $rvgvix;
  482.  
  483.     my $firstix = $first->ix;
  484.     asm "ldop", $firstix unless $firstix == $opix;
  485.     asm "op_sibling", $pushmarkix;
  486.  
  487.     $op->B::OP::bsave($ix);
  488.     asm "op_first", $firstix;
  489.     } elsif ($name eq 'formline') {
  490.     $op->B::UNOP::bsave_fat($ix);
  491.     } else {
  492.     $op->B::OP::bsave($ix);
  493.     }
  494. }
  495.  
  496. # fat versions
  497.  
  498. sub B::OP::bsave_fat {
  499.     my ($op, $ix) = @_;
  500.     my $siblix = $op->sibling->ix;
  501.  
  502.     $op->B::OP::bsave_thin($ix);
  503.     asm "op_sibling", $siblix;
  504.     # asm "op_seq", -1;            XXX don't allocate OPs piece by piece
  505. }
  506.  
  507. sub B::UNOP::bsave_fat {
  508.     my ($op,$ix) = @_;
  509.     my $firstix = $op->first->ix;
  510.  
  511.     $op->B::OP::bsave($ix);
  512.     asm "op_first", $firstix;
  513. }
  514.  
  515. sub B::BINOP::bsave_fat {
  516.     my ($op,$ix) = @_;
  517.     my $last = $op->last;
  518.     my $lastix = $op->last->ix;
  519.     if (VERSION < 5.009 && $op->name eq 'aassign' && $last->name eq 'null') {
  520.     asm "ldop", $lastix unless $lastix == $opix;
  521.     asm "op_targ", $last->targ;
  522.     }
  523.  
  524.     $op->B::UNOP::bsave($ix);
  525.     asm "op_last", $lastix;
  526. }
  527.  
  528. sub B::LOGOP::bsave {
  529.     my ($op,$ix) = @_;
  530.     my $otherix = $op->other->ix;
  531.  
  532.     $op->B::UNOP::bsave($ix);
  533.     asm "op_other", $otherix;
  534. }
  535.  
  536. sub B::PMOP::bsave {
  537.     my ($op,$ix) = @_;
  538.     my ($rrop, $rrarg, $rstart);
  539.  
  540.     # my $pmnextix = $op->pmnext->ix;    # XXX
  541.  
  542.     if (ITHREADS) {
  543.     if ($op->name eq 'subst') {
  544.         $rrop = "op_pmreplroot";
  545.         $rrarg = $op->pmreplroot->ix;
  546.         $rstart = $op->pmreplstart->ix;
  547.     } elsif ($op->name eq 'pushre') {
  548.         $rrop = "op_pmreplrootpo";
  549.         $rrarg = $op->pmreplroot;
  550.     }
  551.     $op->B::BINOP::bsave($ix);
  552.     asm "op_pmstashpv", pvix $op->pmstashpv;
  553.     } else {
  554.     $rrop = "op_pmreplrootgv";
  555.     $rrarg = $op->pmreplroot->ix;
  556.     $rstart = $op->pmreplstart->ix if $op->name eq 'subst';
  557.     my $stashix = $op->pmstash->ix;
  558.     $op->B::BINOP::bsave($ix);
  559.     asm "op_pmstash", $stashix;
  560.     }
  561.  
  562.     asm $rrop, $rrarg if $rrop;
  563.     asm "op_pmreplstart", $rstart if $rstart;
  564.  
  565.     asm "op_pmflags", $op->pmflags;
  566.     asm "op_pmpermflags", $op->pmpermflags;
  567.     asm "op_pmdynflags", $op->pmdynflags;
  568.     # asm "op_pmnext", $pmnextix;    # XXX
  569.     asm "newpv", pvstring $op->precomp;
  570.     asm "pregcomp";
  571. }
  572.  
  573. sub B::SVOP::bsave {
  574.     my ($op,$ix) = @_;
  575.     my $svix = $op->sv->ix;
  576.  
  577.     $op->B::OP::bsave($ix);
  578.     asm "op_sv", $svix;
  579. }
  580.  
  581. sub B::PADOP::bsave {
  582.     my ($op,$ix) = @_;
  583.  
  584.     $op->B::OP::bsave($ix);
  585.     asm "op_padix", $op->padix;
  586. }
  587.  
  588. sub B::PVOP::bsave {
  589.     my ($op,$ix) = @_;
  590.     $op->B::OP::bsave($ix);
  591.     return unless my $pv = $op->pv;
  592.  
  593.     if ($op->name eq 'trans') {
  594.         asm "op_pv_tr", join ',', length($pv)/2, unpack("s*", $pv);
  595.     } else {
  596.         asm "newpv", pvstring $pv;
  597.         asm "op_pv";
  598.     }
  599. }
  600.  
  601. sub B::LOOP::bsave {
  602.     my ($op,$ix) = @_;
  603.     my $nextix = $op->nextop->ix;
  604.     my $lastix = $op->lastop->ix;
  605.     my $redoix = $op->redoop->ix;
  606.  
  607.     $op->B::BINOP::bsave($ix);
  608.     asm "op_redoop", $redoix;
  609.     asm "op_nextop", $nextix;
  610.     asm "op_lastop", $lastix;
  611. }
  612.  
  613. sub B::COP::bsave {
  614.     my ($cop,$ix) = @_;
  615.     my $warnix = $cop->warnings->ix;
  616.     my $ioix = $cop->io->ix;
  617.     if (ITHREADS) {
  618.     $cop->B::OP::bsave($ix);
  619.     asm "cop_stashpv", pvix $cop->stashpv;
  620.     asm "cop_file", pvix $cop->file;
  621.     } else {
  622.         my $stashix = $cop->stash->ix;
  623.         my $fileix = $cop->filegv->ix(1);
  624.     $cop->B::OP::bsave($ix);
  625.     asm "cop_stash", $stashix;
  626.     asm "cop_filegv", $fileix;
  627.     }
  628.     asm "cop_label", pvix $cop->label if $cop->label;    # XXX AD
  629.     asm "cop_seq", $cop->cop_seq;
  630.     asm "cop_arybase", $cop->arybase;
  631.     asm "cop_line", $cop->line;
  632.     asm "cop_warnings", $warnix;
  633.     asm "cop_io", $ioix;
  634. }
  635.  
  636. sub B::OP::opwalk {
  637.     my $op = shift;
  638.     my $ix = $optab{$$op};
  639.     defined($ix) ? $ix : do {
  640.     my $ix;
  641.     my @oplist = $op->oplist;
  642.     push @cloop, undef;
  643.     $ix = $_->ix while $_ = pop @oplist;
  644.     while ($_ = pop @cloop) {
  645.         asm "ldop", $optab{$$_};
  646.         asm "op_next", $optab{${$_->next}};
  647.     }
  648.     $ix;
  649.     }
  650. }
  651.  
  652. #################################################
  653.  
  654. sub save_cq {
  655.     my $av;
  656.     if (($av=begin_av)->isa("B::AV")) {
  657.     if ($savebegins) {
  658.         for ($av->ARRAY) {
  659.         next unless $_->FILE eq $0;
  660.         asm "push_begin", $_->ix;
  661.         }
  662.     } else {
  663.         for ($av->ARRAY) {
  664.         next unless $_->FILE eq $0;
  665.         # XXX BEGIN { goto A while 1; A: }
  666.         for (my $op = $_->START; $$op; $op = $op->next) {
  667.             next unless $op->name eq 'require' || 
  668.             # this kludge needed for tests
  669.             $op->name eq 'gv' && do {
  670.                 my $gv = class($op) eq 'SVOP' ?
  671.                 $op->gv :
  672.                     (($_->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
  673.                 $$gv && $gv->NAME =~ /use_ok|plan/
  674.             };
  675.             asm "push_begin", $_->ix;
  676.             last;
  677.         }
  678.         }
  679.     }
  680.     }
  681.     if (($av=init_av)->isa("B::AV")) {
  682.     for ($av->ARRAY) {
  683.         next unless $_->FILE eq $0;
  684.         asm "push_init", $_->ix;
  685.     }
  686.     }
  687.     if (($av=end_av)->isa("B::AV")) {
  688.     for ($av->ARRAY) {
  689.         next unless $_->FILE eq $0;
  690.         asm "push_end", $_->ix;
  691.     }
  692.     }
  693. }
  694.  
  695. sub compile {
  696.     my ($head, $scan, $T_inhinc, $keep_syn);
  697.     my $cwd = '';
  698.     $files{$0} = 1;
  699.     sub keep_syn {
  700.     $keep_syn = 1;
  701.     *B::OP::bsave = *B::OP::bsave_fat;
  702.     *B::UNOP::bsave = *B::UNOP::bsave_fat;
  703.     *B::BINOP::bsave = *B::BINOP::bsave_fat;
  704.     *B::LISTOP::bsave = *B::LISTOP::bsave_fat;
  705.     }
  706.     sub bwarn { print STDERR "Bytecode.pm: @_\n" }
  707.  
  708.     for (@_) {
  709.     if (/^-S/) {
  710.         *newasm = *endasm = sub { };
  711.         *asm = sub { print "    @_\n" };
  712.         *nice = sub ($) { print "\n@_\n" };
  713.     } elsif (/^-H/) {
  714.         require ByteLoader;
  715.         $head = "#! $^X\nuse ByteLoader $ByteLoader::VERSION;\n";
  716.     } elsif (/^-k/) {
  717.         keep_syn;
  718.     } elsif (/^-o(.*)$/) {
  719.         open STDOUT, ">$1" or die "open $1: $!";
  720.     } elsif (/^-f(.*)$/) {
  721.         $files{$1} = 1;
  722.     } elsif (/^-s(.*)$/) {
  723.         $scan = length($1) ? $1 : $0;
  724.     } elsif (/^-b/) {
  725.         $savebegins = 1;
  726.     # this is here for the testsuite
  727.     } elsif (/^-TI/) {
  728.         $T_inhinc = 1;
  729.     } elsif (/^-TF(.*)/) {
  730.         my $thatfile = $1;
  731.         *B::COP::file = sub { $thatfile };
  732.     } else {
  733.         bwarn "Ignoring '$_' option";
  734.     }
  735.     }
  736.     if ($scan) {
  737.     my $f;
  738.     if (open $f, $scan) {
  739.         while (<$f>) {
  740.         /^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1;
  741.         /^#/ and next;
  742.         if (/\bgoto\b\s*[^&]/ && !$keep_syn) {
  743.             bwarn "keeping the syntax tree: \"goto\" op found";
  744.             keep_syn;
  745.         }
  746.         }
  747.     } else {
  748.         bwarn "cannot rescan '$scan'";
  749.     }
  750.     close $f;
  751.     }
  752.     binmode STDOUT;
  753.     return sub {
  754.     print $head if $head;
  755.     newasm sub { print @_ };
  756.  
  757.     defstash->bwalk;
  758.     asm "main_start", main_start->opwalk;
  759.     asm "main_root", main_root->ix;
  760.     asm "main_cv", main_cv->ix;
  761.     asm "curpad", (comppadlist->ARRAY)[1]->ix;
  762.  
  763.     asm "signal", cstring "__WARN__"        # XXX
  764.         if warnhook->ix;
  765.     asm "incav", inc_gv->AV->ix if $T_inhinc;
  766.     save_cq;
  767.     asm "incav", inc_gv->AV->ix if $T_inhinc;
  768.     asm "dowarn", dowarn;
  769.  
  770.     {
  771.         no strict 'refs';
  772.         nice "<DATA>";
  773.         my $dh = *{defstash->NAME."::DATA"};
  774.         unless (eof $dh) {
  775.         local undef $/;
  776.         asm "data", ord 'D';
  777.         print <$dh>;
  778.         } else {
  779.         asm "ret";
  780.         }
  781.     }
  782.  
  783.     endasm;
  784.     }
  785. }
  786.  
  787. 1;
  788.  
  789. =head1 NAME
  790.  
  791. B::Bytecode - Perl compiler's bytecode backend
  792.  
  793. =head1 SYNOPSIS
  794.  
  795. B<perl -MO=Bytecode>[B<,-H>][B<,-o>I<script.plc>] I<script.pl>
  796.  
  797. =head1 DESCRIPTION
  798.  
  799. Compiles a Perl script into a bytecode format that could be loaded
  800. later by the ByteLoader module and executed as a regular Perl script.
  801.  
  802. =head1 EXAMPLE
  803.  
  804.     $ perl -MO=Bytecode,-H,-ohi -e 'print "hi!\n"'
  805.     $ perl hi
  806.     hi!
  807.  
  808. =head1 OPTIONS
  809.  
  810. =over 4
  811.  
  812. =item B<-b>
  813.  
  814. Save all the BEGIN blocks. Normally only BEGIN blocks that C<require>
  815. other files (ex. C<use Foo;>) are saved.
  816.  
  817. =item B<-H>
  818.  
  819. prepend a C<use ByteLoader VERSION;> line to the produced bytecode.
  820.  
  821. =item B<-k>
  822.  
  823. keep the syntax tree - it is stripped by default.
  824.  
  825. =item B<-o>I<outfile>
  826.  
  827. put the bytecode in <outfile> instead of dumping it to STDOUT.
  828.  
  829. =item B<-s>
  830.  
  831. scan the script for C<# line ..> directives and for <goto LABEL>
  832. expressions. When gotos are found keep the syntax tree.
  833.  
  834. =back
  835.  
  836. =head1 KNOWN BUGS
  837.  
  838. =over 4
  839.  
  840. =item *
  841.  
  842. C<BEGIN { goto A: while 1; A: }> won't even compile.
  843.  
  844. =item *
  845.  
  846. C<?...?> and C<reset> do not work as expected.
  847.  
  848. =item *
  849.  
  850. variables in C<(?{ ... })> constructs are not properly scoped.
  851.  
  852. =item *
  853.  
  854. scripts that use source filters will fail miserably. 
  855.  
  856. =back
  857.  
  858. =head1 NOTICE
  859.  
  860. There are also undocumented bugs and options.
  861.  
  862. THIS CODE IS HIGHLY EXPERIMENTAL. USE AT YOUR OWN RISK.
  863.  
  864. =head1 AUTHORS
  865.  
  866. Originally written by Malcolm Beattie <mbeattie@sable.ox.ac.uk> and
  867. modified by Benjamin Stuhl <sho_pi@hotmail.com>.
  868.  
  869. Rewritten by Enache Adrian <enache@rdslink.ro>, 2003 a.d.
  870.  
  871. =cut
  872.