home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / lib / perl / 5.8.8 / B / Bytecode.pm < prev    next >
Encoding:
Perl POD Document  |  2006-07-07  |  20.2 KB  |  890 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_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.         if (VERSION < 5.009) {
  176.         asm "xnv", $hv->NVX;
  177.         }
  178.         asm "xmg_stash", $stashix;
  179.         asm "xhv_riter", $hv->RITER;
  180.     }
  181.     asm "sv_refcnt", $hv->REFCNT;
  182.     $ix;
  183.     }
  184. }
  185.  
  186. sub B::NULL::ix {
  187.     my $sv = shift;
  188.     $$sv ? $sv->B::SV::ix : 0;
  189. }
  190.  
  191. sub B::NULL::opwalk { 0 }
  192.  
  193. #################################################
  194.  
  195. sub B::NULL::bsave {
  196.     my ($sv,$ix) = @_;
  197.  
  198.     nice '-'.class($sv).'-',
  199.     asm "ldsv", $varix = $ix unless $ix == $varix;
  200.     asm "sv_refcnt", $sv->REFCNT;
  201. }
  202.  
  203. sub B::SV::bsave;
  204.     *B::SV::bsave = *B::NULL::bsave;
  205.  
  206. sub B::RV::bsave {
  207.     my ($sv,$ix) = @_;
  208.     my $rvix = $sv->RV->ix;
  209.     $sv->B::NULL::bsave($ix);
  210.     asm "xrv", $rvix;
  211. }
  212.  
  213. sub B::PV::bsave {
  214.     my ($sv,$ix) = @_;
  215.     $sv->B::NULL::bsave($ix);
  216.     asm "newpv", pvstring $sv->PVBM;
  217.     asm "xpv";
  218. }
  219.  
  220. sub B::IV::bsave {
  221.     my ($sv,$ix) = @_;
  222.     $sv->B::NULL::bsave($ix);
  223.     asm "xiv", $sv->IVX;
  224. }
  225.  
  226. sub B::NV::bsave {
  227.     my ($sv,$ix) = @_;
  228.     $sv->B::NULL::bsave($ix);
  229.     asm "xnv", sprintf "%.40g", $sv->NVX;
  230. }
  231.  
  232. sub B::PVIV::bsave {
  233.     my ($sv,$ix) = @_;
  234.     $sv->POK ?
  235.     $sv->B::PV::bsave($ix):
  236.     $sv->ROK ?
  237.     $sv->B::RV::bsave($ix):
  238.     $sv->B::NULL::bsave($ix);
  239.     if (VERSION >= 5.009) {
  240.     # See note below in B::PVNV::bsave
  241.     return if $sv->isa('B::AV');
  242.     return if $sv->isa('B::HV');
  243.     }
  244.     asm "xiv", !ITHREADS && $sv->FLAGS & (SVf_FAKE|SVf_READONLY) ?
  245.     "0 but true" : $sv->IVX;
  246. }
  247.  
  248. sub B::PVNV::bsave {
  249.     my ($sv,$ix) = @_;
  250.     $sv->B::PVIV::bsave($ix);
  251.     if (VERSION >= 5.009) {
  252.     # Magical AVs end up here, but AVs now don't have an NV slot actually
  253.     # allocated. Hence don't write out assembly to store the NV slot if
  254.     # we're actually an array.
  255.     return if $sv->isa('B::AV');
  256.     # Likewise HVs have no NV slot actually allocated.
  257.     # I don't think that they can get here, but better safe than sorry
  258.     return if $sv->isa('B::HV');
  259.     }
  260.     asm "xnv", sprintf "%.40g", $sv->NVX;
  261. }
  262.  
  263. sub B::PVMG::domagic {
  264.     my ($sv,$ix) = @_;
  265.     nice '-MAGICAL-';
  266.     my @mglist = $sv->MAGIC;
  267.     my (@mgix, @namix);
  268.     for (@mglist) {
  269.     push @mgix, $_->OBJ->ix;
  270.     push @namix, $_->PTR->ix if $_->LENGTH == B::HEf_SVKEY;
  271.     }
  272.  
  273.     nice '-'.class($sv).'-',
  274.     asm "ldsv", $varix = $ix unless $ix == $varix;
  275.     for (@mglist) {
  276.     asm "sv_magic", cstring $_->TYPE;
  277.     asm "mg_obj", shift @mgix;
  278.     my $length = $_->LENGTH;
  279.     if ($length == B::HEf_SVKEY) {
  280.         asm "mg_namex", shift @namix;
  281.     } elsif ($length) {
  282.         asm "newpv", pvstring $_->PTR;
  283.         asm "mg_name";
  284.     }
  285.     }
  286. }
  287.  
  288. sub B::PVMG::bsave {
  289.     my ($sv,$ix) = @_;
  290.     my $stashix = $sv->SvSTASH->ix;
  291.     $sv->B::PVNV::bsave($ix);
  292.     asm "xmg_stash", $stashix;
  293.     $sv->domagic($ix) if $sv->MAGICAL;
  294. }
  295.  
  296. sub B::PVLV::bsave {
  297.     my ($sv,$ix) = @_;
  298.     my $targix = $sv->TARG->ix;
  299.     $sv->B::PVMG::bsave($ix);
  300.     asm "xlv_targ", $targix;
  301.     asm "xlv_targoff", $sv->TARGOFF;
  302.     asm "xlv_targlen", $sv->TARGLEN;
  303.     asm "xlv_type", $sv->TYPE;
  304.  
  305. }
  306.  
  307. sub B::BM::bsave {
  308.     my ($sv,$ix) = @_;
  309.     $sv->B::PVMG::bsave($ix);
  310.     asm "xpv_cur", $sv->CUR;
  311.     asm "xbm_useful", $sv->USEFUL;
  312.     asm "xbm_previous", $sv->PREVIOUS;
  313.     asm "xbm_rare", $sv->RARE;
  314. }
  315.  
  316. sub B::IO::bsave {
  317.     my ($io,$ix) = @_;
  318.     my $topix = $io->TOP_GV->ix;
  319.     my $fmtix = $io->FMT_GV->ix;
  320.     my $bottomix = $io->BOTTOM_GV->ix;
  321.     $io->B::PVMG::bsave($ix);
  322.     asm "xio_lines", $io->LINES;
  323.     asm "xio_page", $io->PAGE;
  324.     asm "xio_page_len", $io->PAGE_LEN;
  325.     asm "xio_lines_left", $io->LINES_LEFT;
  326.     asm "xio_top_name", pvix $io->TOP_NAME;
  327.     asm "xio_top_gv", $topix;
  328.     asm "xio_fmt_name", pvix $io->FMT_NAME;
  329.     asm "xio_fmt_gv", $fmtix;
  330.     asm "xio_bottom_name", pvix $io->BOTTOM_NAME;
  331.     asm "xio_bottom_gv", $bottomix;
  332.     asm "xio_subprocess", $io->SUBPROCESS;
  333.     asm "xio_type", ord $io->IoTYPE;
  334.     # asm "xio_flags", ord($io->IoFLAGS) & ~32;        # XXX XXX
  335. }
  336.  
  337. sub B::CV::bsave {
  338.     my ($cv,$ix) = @_;
  339.     my $stashix = $cv->STASH->ix;
  340.     my $gvix = $cv->GV->ix;
  341.     my $padlistix = $cv->PADLIST->ix;
  342.     my $outsideix = $cv->OUTSIDE->ix;
  343.     my $constix = $cv->CONST ? $cv->XSUBANY->ix : 0;
  344.     my $startix = $cv->START->opwalk;
  345.     my $rootix = $cv->ROOT->ix;
  346.  
  347.     $cv->B::PVMG::bsave($ix);
  348.     asm "xcv_stash", $stashix;
  349.     asm "xcv_start", $startix;
  350.     asm "xcv_root", $rootix;
  351.     asm "xcv_xsubany", $constix;
  352.     asm "xcv_gv", $gvix;
  353.     asm "xcv_file", pvix $cv->FILE if $cv->FILE;    # XXX AD
  354.     asm "xcv_padlist", $padlistix;
  355.     asm "xcv_outside", $outsideix;
  356.     asm "xcv_flags", $cv->CvFLAGS;
  357.     asm "xcv_outside_seq", $cv->OUTSIDE_SEQ;
  358.     asm "xcv_depth", $cv->DEPTH;
  359. }
  360.  
  361. sub B::FM::bsave {
  362.     my ($form,$ix) = @_;
  363.  
  364.     $form->B::CV::bsave($ix);
  365.     asm "xfm_lines", $form->LINES;
  366. }
  367.  
  368. sub B::AV::bsave {
  369.     my ($av,$ix) = @_;
  370.     return $av->B::PVMG::bsave($ix) if $av->MAGICAL;
  371.     my @array = $av->ARRAY;
  372.     $_ = $_->ix for @array;
  373.     my $stashix = $av->SvSTASH->ix;
  374.  
  375.     nice "-AV-",
  376.     asm "ldsv", $varix = $ix unless $ix == $varix;
  377.     asm "av_extend", $av->MAX if $av->MAX >= 0;
  378.     asm "av_pushx", $_ for @array;
  379.     asm "sv_refcnt", $av->REFCNT;
  380.     if (VERSION < 5.009) {
  381.     asm "xav_flags", $av->AvFLAGS;
  382.     }
  383.     asm "xmg_stash", $stashix;
  384. }
  385.  
  386. sub B::GV::desired {
  387.     my $gv = shift;
  388.     my ($cv, $form);
  389.     $files{$gv->FILE} && $gv->LINE
  390.     || ${$cv = $gv->CV} && $files{$cv->FILE}
  391.     || ${$form = $gv->FORM} && $files{$form->FILE}
  392. }
  393.  
  394. sub B::HV::bwalk {
  395.     my $hv = shift;
  396.     return if $walked{$$hv}++;
  397.     my %stash = $hv->ARRAY;
  398.     while (my($k,$v) = each %stash) {
  399.     if ($v->SvTYPE == SVt_PVGV) {
  400.         my $hash = $v->HV;
  401.         if ($$hash && $hash->NAME) {
  402.         $hash->bwalk;
  403.         } 
  404.         $v->ix(1) if desired $v;
  405.     } else {
  406.         nice "[prototype]";
  407.         asm "gv_fetchpvx", cstring $hv->NAME . "::$k";
  408.         $svtab{$$v} = $varix = $tix;
  409.         $v->bsave($tix++);
  410.         asm "sv_flags", $v->FLAGS;
  411.     }
  412.     }
  413. }
  414.  
  415. ######################################################
  416.  
  417.  
  418. sub B::OP::bsave_thin {
  419.     my ($op, $ix) = @_;
  420.     my $next = $op->next;
  421.     my $nextix = $optab{$$next};
  422.     $nextix = 0, push @cloop, $op unless defined $nextix;
  423.     if ($ix != $opix) {
  424.     nice '-'.$op->name.'-',
  425.     asm "ldop", $opix = $ix;
  426.     }
  427.     asm "op_next", $nextix;
  428.     asm "op_targ", $op->targ if $op->type;        # tricky
  429.     asm "op_flags", $op->flags;
  430.     asm "op_private", $op->private;
  431. }
  432.  
  433. sub B::OP::bsave;
  434.     *B::OP::bsave = *B::OP::bsave_thin;
  435.  
  436. sub B::UNOP::bsave {
  437.     my ($op, $ix) = @_;
  438.     my $name = $op->name;
  439.     my $flags = $op->flags;
  440.     my $first = $op->first;
  441.     my $firstix = 
  442.     $name =~ /fl[io]p/
  443.             # that's just neat
  444.     ||    (!ITHREADS && $name eq 'regcomp')
  445.             # trick for /$a/o in pp_regcomp
  446.     ||    $name eq 'rv2sv'
  447.         && $op->flags & OPf_MOD    
  448.         && $op->private & OPpLVAL_INTRO
  449.             # change #18774 made my life hard
  450.     ?    $first->ix
  451.     :    0;
  452.  
  453.     $op->B::OP::bsave($ix);
  454.     asm "op_first", $firstix;
  455. }
  456.  
  457. sub B::BINOP::bsave {
  458.     my ($op, $ix) = @_;
  459.     if ($op->name eq 'aassign' && $op->private & B::OPpASSIGN_HASH()) {
  460.     my $last = $op->last;
  461.     my $lastix = do {
  462.         local *B::OP::bsave = *B::OP::bsave_fat;
  463.         local *B::UNOP::bsave = *B::UNOP::bsave_fat;
  464.         $last->ix;
  465.     };
  466.     asm "ldop", $lastix unless $lastix == $opix;
  467.     asm "op_targ", $last->targ;
  468.     $op->B::OP::bsave($ix);
  469.     asm "op_last", $lastix;
  470.     } else {
  471.     $op->B::OP::bsave($ix);
  472.     }
  473. }
  474.  
  475. # not needed if no pseudohashes
  476.  
  477. *B::BINOP::bsave = *B::OP::bsave if VERSION >= 5.009;
  478.  
  479. # deal with sort / formline 
  480.  
  481. sub B::LISTOP::bsave {
  482.     my ($op, $ix) = @_;
  483.     my $name = $op->name;
  484.     sub blocksort() { OPf_SPECIAL|OPf_STACKED }
  485.     if ($name eq 'sort' && ($op->flags & blocksort) == blocksort) {
  486.     my $first = $op->first;
  487.     my $pushmark = $first->sibling;
  488.     my $rvgv = $pushmark->first;
  489.     my $leave = $rvgv->first;
  490.  
  491.     my $leaveix = $leave->ix;
  492.  
  493.     my $rvgvix = $rvgv->ix;
  494.     asm "ldop", $rvgvix unless $rvgvix == $opix;
  495.     asm "op_first", $leaveix;
  496.  
  497.     my $pushmarkix = $pushmark->ix;
  498.     asm "ldop", $pushmarkix unless $pushmarkix == $opix;
  499.     asm "op_first", $rvgvix;
  500.  
  501.     my $firstix = $first->ix;
  502.     asm "ldop", $firstix unless $firstix == $opix;
  503.     asm "op_sibling", $pushmarkix;
  504.  
  505.     $op->B::OP::bsave($ix);
  506.     asm "op_first", $firstix;
  507.     } elsif ($name eq 'formline') {
  508.     $op->B::UNOP::bsave_fat($ix);
  509.     } else {
  510.     $op->B::OP::bsave($ix);
  511.     }
  512. }
  513.  
  514. # fat versions
  515.  
  516. sub B::OP::bsave_fat {
  517.     my ($op, $ix) = @_;
  518.     my $siblix = $op->sibling->ix;
  519.  
  520.     $op->B::OP::bsave_thin($ix);
  521.     asm "op_sibling", $siblix;
  522.     # asm "op_seq", -1;            XXX don't allocate OPs piece by piece
  523. }
  524.  
  525. sub B::UNOP::bsave_fat {
  526.     my ($op,$ix) = @_;
  527.     my $firstix = $op->first->ix;
  528.  
  529.     $op->B::OP::bsave($ix);
  530.     asm "op_first", $firstix;
  531. }
  532.  
  533. sub B::BINOP::bsave_fat {
  534.     my ($op,$ix) = @_;
  535.     my $last = $op->last;
  536.     my $lastix = $op->last->ix;
  537.     if (VERSION < 5.009 && $op->name eq 'aassign' && $last->name eq 'null') {
  538.     asm "ldop", $lastix unless $lastix == $opix;
  539.     asm "op_targ", $last->targ;
  540.     }
  541.  
  542.     $op->B::UNOP::bsave($ix);
  543.     asm "op_last", $lastix;
  544. }
  545.  
  546. sub B::LOGOP::bsave {
  547.     my ($op,$ix) = @_;
  548.     my $otherix = $op->other->ix;
  549.  
  550.     $op->B::UNOP::bsave($ix);
  551.     asm "op_other", $otherix;
  552. }
  553.  
  554. sub B::PMOP::bsave {
  555.     my ($op,$ix) = @_;
  556.     my ($rrop, $rrarg, $rstart);
  557.  
  558.     # my $pmnextix = $op->pmnext->ix;    # XXX
  559.  
  560.     if (ITHREADS) {
  561.     if ($op->name eq 'subst') {
  562.         $rrop = "op_pmreplroot";
  563.         $rrarg = $op->pmreplroot->ix;
  564.         $rstart = $op->pmreplstart->ix;
  565.     } elsif ($op->name eq 'pushre') {
  566.         $rrop = "op_pmreplrootpo";
  567.         $rrarg = $op->pmreplroot;
  568.     }
  569.     $op->B::BINOP::bsave($ix);
  570.     asm "op_pmstashpv", pvix $op->pmstashpv;
  571.     } else {
  572.     $rrop = "op_pmreplrootgv";
  573.     $rrarg = $op->pmreplroot->ix;
  574.     $rstart = $op->pmreplstart->ix if $op->name eq 'subst';
  575.     my $stashix = $op->pmstash->ix;
  576.     $op->B::BINOP::bsave($ix);
  577.     asm "op_pmstash", $stashix;
  578.     }
  579.  
  580.     asm $rrop, $rrarg if $rrop;
  581.     asm "op_pmreplstart", $rstart if $rstart;
  582.  
  583.     asm "op_pmflags", $op->pmflags;
  584.     asm "op_pmpermflags", $op->pmpermflags;
  585.     asm "op_pmdynflags", $op->pmdynflags;
  586.     # asm "op_pmnext", $pmnextix;    # XXX
  587.     asm "newpv", pvstring $op->precomp;
  588.     asm "pregcomp";
  589. }
  590.  
  591. sub B::SVOP::bsave {
  592.     my ($op,$ix) = @_;
  593.     my $svix = $op->sv->ix;
  594.  
  595.     $op->B::OP::bsave($ix);
  596.     asm "op_sv", $svix;
  597. }
  598.  
  599. sub B::PADOP::bsave {
  600.     my ($op,$ix) = @_;
  601.  
  602.     $op->B::OP::bsave($ix);
  603.     asm "op_padix", $op->padix;
  604. }
  605.  
  606. sub B::PVOP::bsave {
  607.     my ($op,$ix) = @_;
  608.     $op->B::OP::bsave($ix);
  609.     return unless my $pv = $op->pv;
  610.  
  611.     if ($op->name eq 'trans') {
  612.         asm "op_pv_tr", join ',', length($pv)/2, unpack("s*", $pv);
  613.     } else {
  614.         asm "newpv", pvstring $pv;
  615.         asm "op_pv";
  616.     }
  617. }
  618.  
  619. sub B::LOOP::bsave {
  620.     my ($op,$ix) = @_;
  621.     my $nextix = $op->nextop->ix;
  622.     my $lastix = $op->lastop->ix;
  623.     my $redoix = $op->redoop->ix;
  624.  
  625.     $op->B::BINOP::bsave($ix);
  626.     asm "op_redoop", $redoix;
  627.     asm "op_nextop", $nextix;
  628.     asm "op_lastop", $lastix;
  629. }
  630.  
  631. sub B::COP::bsave {
  632.     my ($cop,$ix) = @_;
  633.     my $warnix = $cop->warnings->ix;
  634.     my $ioix = $cop->io->ix;
  635.     if (ITHREADS) {
  636.     $cop->B::OP::bsave($ix);
  637.     asm "cop_stashpv", pvix $cop->stashpv;
  638.     asm "cop_file", pvix $cop->file;
  639.     } else {
  640.         my $stashix = $cop->stash->ix;
  641.         my $fileix = $cop->filegv->ix(1);
  642.     $cop->B::OP::bsave($ix);
  643.     asm "cop_stash", $stashix;
  644.     asm "cop_filegv", $fileix;
  645.     }
  646.     asm "cop_label", pvix $cop->label if $cop->label;    # XXX AD
  647.     asm "cop_seq", $cop->cop_seq;
  648.     asm "cop_arybase", $cop->arybase;
  649.     asm "cop_line", $cop->line;
  650.     asm "cop_warnings", $warnix;
  651.     asm "cop_io", $ioix;
  652. }
  653.  
  654. sub B::OP::opwalk {
  655.     my $op = shift;
  656.     my $ix = $optab{$$op};
  657.     defined($ix) ? $ix : do {
  658.     my $ix;
  659.     my @oplist = $op->oplist;
  660.     push @cloop, undef;
  661.     $ix = $_->ix while $_ = pop @oplist;
  662.     while ($_ = pop @cloop) {
  663.         asm "ldop", $optab{$$_};
  664.         asm "op_next", $optab{${$_->next}};
  665.     }
  666.     $ix;
  667.     }
  668. }
  669.  
  670. #################################################
  671.  
  672. sub save_cq {
  673.     my $av;
  674.     if (($av=begin_av)->isa("B::AV")) {
  675.     if ($savebegins) {
  676.         for ($av->ARRAY) {
  677.         next unless $_->FILE eq $0;
  678.         asm "push_begin", $_->ix;
  679.         }
  680.     } else {
  681.         for ($av->ARRAY) {
  682.         next unless $_->FILE eq $0;
  683.         # XXX BEGIN { goto A while 1; A: }
  684.         for (my $op = $_->START; $$op; $op = $op->next) {
  685.             next unless $op->name eq 'require' || 
  686.             # this kludge needed for tests
  687.             $op->name eq 'gv' && do {
  688.                 my $gv = class($op) eq 'SVOP' ?
  689.                 $op->gv :
  690.                     (($_->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
  691.                 $$gv && $gv->NAME =~ /use_ok|plan/
  692.             };
  693.             asm "push_begin", $_->ix;
  694.             last;
  695.         }
  696.         }
  697.     }
  698.     }
  699.     if (($av=init_av)->isa("B::AV")) {
  700.     for ($av->ARRAY) {
  701.         next unless $_->FILE eq $0;
  702.         asm "push_init", $_->ix;
  703.     }
  704.     }
  705.     if (($av=end_av)->isa("B::AV")) {
  706.     for ($av->ARRAY) {
  707.         next unless $_->FILE eq $0;
  708.         asm "push_end", $_->ix;
  709.     }
  710.     }
  711. }
  712.  
  713. sub compile {
  714.     my ($head, $scan, $T_inhinc, $keep_syn);
  715.     my $cwd = '';
  716.     $files{$0} = 1;
  717.     sub keep_syn {
  718.     $keep_syn = 1;
  719.     *B::OP::bsave = *B::OP::bsave_fat;
  720.     *B::UNOP::bsave = *B::UNOP::bsave_fat;
  721.     *B::BINOP::bsave = *B::BINOP::bsave_fat;
  722.     *B::LISTOP::bsave = *B::LISTOP::bsave_fat;
  723.     }
  724.     sub bwarn { print STDERR "Bytecode.pm: @_\n" }
  725.  
  726.     for (@_) {
  727.     if (/^-S/) {
  728.         *newasm = *endasm = sub { };
  729.         *asm = sub { print "    @_\n" };
  730.         *nice = sub ($) { print "\n@_\n" };
  731.     } elsif (/^-H/) {
  732.         require ByteLoader;
  733.         $head = "#! $^X\nuse ByteLoader $ByteLoader::VERSION;\n";
  734.     } elsif (/^-k/) {
  735.         keep_syn;
  736.     } elsif (/^-o(.*)$/) {
  737.         open STDOUT, ">$1" or die "open $1: $!";
  738.     } elsif (/^-f(.*)$/) {
  739.         $files{$1} = 1;
  740.     } elsif (/^-s(.*)$/) {
  741.         $scan = length($1) ? $1 : $0;
  742.     } elsif (/^-b/) {
  743.         $savebegins = 1;
  744.     # this is here for the testsuite
  745.     } elsif (/^-TI/) {
  746.         $T_inhinc = 1;
  747.     } elsif (/^-TF(.*)/) {
  748.         my $thatfile = $1;
  749.         *B::COP::file = sub { $thatfile };
  750.     } else {
  751.         bwarn "Ignoring '$_' option";
  752.     }
  753.     }
  754.     if ($scan) {
  755.     my $f;
  756.     if (open $f, $scan) {
  757.         while (<$f>) {
  758.         /^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1;
  759.         /^#/ and next;
  760.         if (/\bgoto\b\s*[^&]/ && !$keep_syn) {
  761.             bwarn "keeping the syntax tree: \"goto\" op found";
  762.             keep_syn;
  763.         }
  764.         }
  765.     } else {
  766.         bwarn "cannot rescan '$scan'";
  767.     }
  768.     close $f;
  769.     }
  770.     binmode STDOUT;
  771.     return sub {
  772.     print $head if $head;
  773.     newasm sub { print @_ };
  774.  
  775.     defstash->bwalk;
  776.     asm "main_start", main_start->opwalk;
  777.     asm "main_root", main_root->ix;
  778.     asm "main_cv", main_cv->ix;
  779.     asm "curpad", (comppadlist->ARRAY)[1]->ix;
  780.  
  781.     asm "signal", cstring "__WARN__"        # XXX
  782.         if warnhook->ix;
  783.     asm "incav", inc_gv->AV->ix if $T_inhinc;
  784.     save_cq;
  785.     asm "incav", inc_gv->AV->ix if $T_inhinc;
  786.     asm "dowarn", dowarn;
  787.  
  788.     {
  789.         no strict 'refs';
  790.         nice "<DATA>";
  791.         my $dh = *{defstash->NAME."::DATA"};
  792.         unless (eof $dh) {
  793.         local undef $/;
  794.         asm "data", ord 'D';
  795.         print <$dh>;
  796.         } else {
  797.         asm "ret";
  798.         }
  799.     }
  800.  
  801.     endasm;
  802.     }
  803. }
  804.  
  805. 1;
  806.  
  807. =head1 NAME
  808.  
  809. B::Bytecode - Perl compiler's bytecode backend
  810.  
  811. =head1 SYNOPSIS
  812.  
  813. B<perl -MO=Bytecode>[B<,-H>][B<,-o>I<script.plc>] I<script.pl>
  814.  
  815. =head1 DESCRIPTION
  816.  
  817. Compiles a Perl script into a bytecode format that could be loaded
  818. later by the ByteLoader module and executed as a regular Perl script.
  819.  
  820. =head1 EXAMPLE
  821.  
  822.     $ perl -MO=Bytecode,-H,-ohi -e 'print "hi!\n"'
  823.     $ perl hi
  824.     hi!
  825.  
  826. =head1 OPTIONS
  827.  
  828. =over 4
  829.  
  830. =item B<-b>
  831.  
  832. Save all the BEGIN blocks. Normally only BEGIN blocks that C<require>
  833. other files (ex. C<use Foo;>) are saved.
  834.  
  835. =item B<-H>
  836.  
  837. prepend a C<use ByteLoader VERSION;> line to the produced bytecode.
  838.  
  839. =item B<-k>
  840.  
  841. keep the syntax tree - it is stripped by default.
  842.  
  843. =item B<-o>I<outfile>
  844.  
  845. put the bytecode in <outfile> instead of dumping it to STDOUT.
  846.  
  847. =item B<-s>
  848.  
  849. scan the script for C<# line ..> directives and for <goto LABEL>
  850. expressions. When gotos are found keep the syntax tree.
  851.  
  852. =back
  853.  
  854. =head1 KNOWN BUGS
  855.  
  856. =over 4
  857.  
  858. =item *
  859.  
  860. C<BEGIN { goto A: while 1; A: }> won't even compile.
  861.  
  862. =item *
  863.  
  864. C<?...?> and C<reset> do not work as expected.
  865.  
  866. =item *
  867.  
  868. variables in C<(?{ ... })> constructs are not properly scoped.
  869.  
  870. =item *
  871.  
  872. scripts that use source filters will fail miserably. 
  873.  
  874. =back
  875.  
  876. =head1 NOTICE
  877.  
  878. There are also undocumented bugs and options.
  879.  
  880. THIS CODE IS HIGHLY EXPERIMENTAL. USE AT YOUR OWN RISK.
  881.  
  882. =head1 AUTHORS
  883.  
  884. Originally written by Malcolm Beattie <mbeattie@sable.ox.ac.uk> and
  885. modified by Benjamin Stuhl <sho_pi@hotmail.com>.
  886.  
  887. Rewritten by Enache Adrian <enache@rdslink.ro>, 2003 a.d.
  888.  
  889. =cut
  890.