1N/A# B::Bytecode.pm
1N/A# Copyright (c) 2003 Enache Adrian. All rights reserved.
1N/A# This module is free software; you can redistribute and/or modify
1N/A# it under the same terms as Perl itself.
1N/A
1N/A# Based on the original Bytecode.pm module written by Malcolm Beattie.
1N/A
1N/Apackage B::Bytecode;
1N/A
1N/Aour $VERSION = '1.01';
1N/A
1N/Ause strict;
1N/Ause Config;
1N/Ause B qw(class main_cv main_root main_start cstring comppadlist
1N/A defstash curstash begin_av init_av end_av inc_gv warnhook diehook
1N/A dowarn SVt_PVGV SVt_PVHV OPf_SPECIAL OPf_STACKED OPf_MOD
1N/A OPpLVAL_INTRO SVf_FAKE SVf_READONLY);
1N/Ause B::Asmdata qw(@specialsv_name);
1N/Ause B::Assembler qw(asm newasm endasm);
1N/A
1N/A#################################################
1N/A
1N/Amy ($varix, $opix, $savebegins, %walked, %files, @cloop);
1N/Amy %strtab = (0,0);
1N/Amy %svtab = (0,0);
1N/Amy %optab = (0,0);
1N/Amy %spectab = (0,0);
1N/Amy $tix = 1;
1N/Asub asm;
1N/Asub nice ($) { }
1N/A
1N/ABEGIN {
1N/A my $ithreads = $Config{'useithreads'} eq 'define';
1N/A eval qq{
1N/A sub ITHREADS() { $ithreads }
1N/A sub VERSION() { $] }
1N/A }; die $@ if $@;
1N/A}
1N/A
1N/A#################################################
1N/A
1N/Asub pvstring {
1N/A my $pv = shift;
1N/A defined($pv) ? cstring ($pv."\0") : "\"\"";
1N/A}
1N/A
1N/Asub pvix {
1N/A my $str = pvstring shift;
1N/A my $ix = $strtab{$str};
1N/A defined($ix) ? $ix : do {
1N/A asm "newpv", $str;
1N/A asm "stpv", $strtab{$str} = $tix;
1N/A $tix++;
1N/A }
1N/A}
1N/A
1N/Asub B::OP::ix {
1N/A my $op = shift;
1N/A my $ix = $optab{$$op};
1N/A defined($ix) ? $ix : do {
1N/A nice "[".$op->name." $tix]";
1N/A asm "newopx", $op->size | $op->type <<7;
1N/A $optab{$$op} = $opix = $ix = $tix++;
1N/A $op->bsave($ix);
1N/A $ix;
1N/A }
1N/A}
1N/A
1N/Asub B::SPECIAL::ix {
1N/A my $spec = shift;
1N/A my $ix = $spectab{$$spec};
1N/A defined($ix) ? $ix : do {
1N/A nice '['.$specialsv_name[$$spec].']';
1N/A asm "ldspecsvx", $$spec;
1N/A $spectab{$$spec} = $varix = $tix++;
1N/A }
1N/A}
1N/A
1N/Asub B::SV::ix {
1N/A my $sv = shift;
1N/A my $ix = $svtab{$$sv};
1N/A defined($ix) ? $ix : do {
1N/A nice '['.class($sv).']';
1N/A asm "newsvx", $sv->FLAGS;
1N/A $svtab{$$sv} = $varix = $ix = $tix++;
1N/A $sv->bsave($ix);
1N/A $ix;
1N/A }
1N/A}
1N/A
1N/Asub B::GV::ix {
1N/A my ($gv,$desired) = @_;
1N/A my $ix = $svtab{$$gv};
1N/A defined($ix) ? $ix : do {
1N/A if ($gv->GP) {
1N/A my ($svix, $avix, $hvix, $cvix, $ioix, $formix);
1N/A nice "[GV]";
1N/A my $name = $gv->STASH->NAME . "::" . $gv->NAME;
1N/A asm "gv_fetchpvx", cstring $name;
1N/A $svtab{$$gv} = $varix = $ix = $tix++;
1N/A asm "sv_flags", $gv->FLAGS;
1N/A asm "sv_refcnt", $gv->REFCNT;
1N/A asm "xgv_flags", $gv->GvFLAGS;
1N/A
1N/A asm "gp_refcnt", $gv->GvREFCNT;
1N/A asm "load_glob", $ix if $name eq "CORE::GLOBAL::glob";
1N/A return $ix
1N/A unless $desired || desired $gv;
1N/A $svix = $gv->SV->ix;
1N/A $avix = $gv->AV->ix;
1N/A $hvix = $gv->HV->ix;
1N/A
1N/A # XXX {{{{
1N/A my $cv = $gv->CV;
1N/A $cvix = $$cv && defined $files{$cv->FILE} ? $cv->ix : 0;
1N/A my $form = $gv->FORM;
1N/A $formix = $$form && defined $files{$form->FILE} ? $form->ix : 0;
1N/A
1N/A $ioix = $name !~ /STDOUT$/ ? $gv->IO->ix : 0;
1N/A # }}}} XXX
1N/A
1N/A nice "-GV-",
1N/A asm "ldsv", $varix = $ix unless $ix == $varix;
1N/A asm "gp_sv", $svix;
1N/A asm "gp_av", $avix;
1N/A asm "gp_hv", $hvix;
1N/A asm "gp_cv", $cvix;
1N/A asm "gp_io", $ioix;
1N/A asm "gp_cvgen", $gv->CVGEN;
1N/A asm "gp_form", $formix;
1N/A asm "gp_file", pvix $gv->FILE;
1N/A asm "gp_line", $gv->LINE;
1N/A asm "formfeed", $svix if $name eq "main::\cL";
1N/A } else {
1N/A nice "[GV]";
1N/A asm "newsvx", $gv->FLAGS;
1N/A $svtab{$$gv} = $varix = $ix = $tix++;
1N/A my $stashix = $gv->STASH->ix;
1N/A $gv->B::PVMG::bsave($ix);
1N/A asm "xgv_flags", $gv->GvFLAGS;
1N/A asm "xgv_stash", $stashix;
1N/A }
1N/A $ix;
1N/A }
1N/A}
1N/A
1N/Asub B::HV::ix {
1N/A my $hv = shift;
1N/A my $ix = $svtab{$$hv};
1N/A defined($ix) ? $ix : do {
1N/A my ($ix,$i,@array);
1N/A my $name = $hv->NAME;
1N/A if ($name) {
1N/A nice "[STASH]";
1N/A asm "gv_stashpvx", cstring $name;
1N/A asm "sv_flags", $hv->FLAGS;
1N/A $svtab{$$hv} = $varix = $ix = $tix++;
1N/A asm "xhv_name", pvix $name;
1N/A # my $pmrootix = $hv->PMROOT->ix; # XXX
1N/A asm "ldsv", $varix = $ix unless $ix == $varix;
1N/A # asm "xhv_pmroot", $pmrootix; # XXX
1N/A } else {
1N/A nice "[HV]";
1N/A asm "newsvx", $hv->FLAGS;
1N/A $svtab{$$hv} = $varix = $ix = $tix++;
1N/A my $stashix = $hv->SvSTASH->ix;
1N/A for (@array = $hv->ARRAY) {
1N/A next if $i = not $i;
1N/A $_ = $_->ix;
1N/A }
1N/A nice "-HV-",
1N/A asm "ldsv", $varix = $ix unless $ix == $varix;
1N/A ($i = not $i) ? asm ("newpv", pvstring $_) : asm("hv_store", $_)
1N/A for @array;
1N/A asm "xnv", $hv->NVX;
1N/A asm "xmg_stash", $stashix;
1N/A asm "xhv_riter", $hv->RITER;
1N/A }
1N/A asm "sv_refcnt", $hv->REFCNT;
1N/A $ix;
1N/A }
1N/A}
1N/A
1N/Asub B::NULL::ix {
1N/A my $sv = shift;
1N/A $$sv ? $sv->B::SV::ix : 0;
1N/A}
1N/A
1N/Asub B::NULL::opwalk { 0 }
1N/A
1N/A#################################################
1N/A
1N/Asub B::NULL::bsave {
1N/A my ($sv,$ix) = @_;
1N/A
1N/A nice '-'.class($sv).'-',
1N/A asm "ldsv", $varix = $ix unless $ix == $varix;
1N/A asm "sv_refcnt", $sv->REFCNT;
1N/A}
1N/A
1N/Asub B::SV::bsave;
1N/A *B::SV::bsave = *B::NULL::bsave;
1N/A
1N/Asub B::RV::bsave {
1N/A my ($sv,$ix) = @_;
1N/A my $rvix = $sv->RV->ix;
1N/A $sv->B::NULL::bsave($ix);
1N/A asm "xrv", $rvix;
1N/A}
1N/A
1N/Asub B::PV::bsave {
1N/A my ($sv,$ix) = @_;
1N/A $sv->B::NULL::bsave($ix);
1N/A asm "newpv", pvstring $sv->PVBM;
1N/A asm "xpv";
1N/A}
1N/A
1N/Asub B::IV::bsave {
1N/A my ($sv,$ix) = @_;
1N/A $sv->B::NULL::bsave($ix);
1N/A asm "xiv", $sv->IVX;
1N/A}
1N/A
1N/Asub B::NV::bsave {
1N/A my ($sv,$ix) = @_;
1N/A $sv->B::NULL::bsave($ix);
1N/A asm "xnv", sprintf "%.40g", $sv->NVX;
1N/A}
1N/A
1N/Asub B::PVIV::bsave {
1N/A my ($sv,$ix) = @_;
1N/A $sv->POK ?
1N/A $sv->B::PV::bsave($ix):
1N/A $sv->ROK ?
1N/A $sv->B::RV::bsave($ix):
1N/A $sv->B::NULL::bsave($ix);
1N/A asm "xiv", !ITHREADS && $sv->FLAGS & (SVf_FAKE|SVf_READONLY) ?
1N/A "0 but true" : $sv->IVX;
1N/A}
1N/A
1N/Asub B::PVNV::bsave {
1N/A my ($sv,$ix) = @_;
1N/A $sv->B::PVIV::bsave($ix);
1N/A asm "xnv", sprintf "%.40g", $sv->NVX;
1N/A}
1N/A
1N/Asub B::PVMG::domagic {
1N/A my ($sv,$ix) = @_;
1N/A nice '-MAGICAL-';
1N/A my @mglist = $sv->MAGIC;
1N/A my (@mgix, @namix);
1N/A for (@mglist) {
1N/A push @mgix, $_->OBJ->ix;
1N/A push @namix, $_->PTR->ix if $_->LENGTH == B::HEf_SVKEY;
1N/A }
1N/A
1N/A nice '-'.class($sv).'-',
1N/A asm "ldsv", $varix = $ix unless $ix == $varix;
1N/A for (@mglist) {
1N/A asm "sv_magic", cstring $_->TYPE;
1N/A asm "mg_obj", shift @mgix;
1N/A my $length = $_->LENGTH;
1N/A if ($length == B::HEf_SVKEY) {
1N/A asm "mg_namex", shift @namix;
1N/A } elsif ($length) {
1N/A asm "newpv", pvstring $_->PTR;
1N/A asm "mg_name";
1N/A }
1N/A }
1N/A}
1N/A
1N/Asub B::PVMG::bsave {
1N/A my ($sv,$ix) = @_;
1N/A my $stashix = $sv->SvSTASH->ix;
1N/A $sv->B::PVNV::bsave($ix);
1N/A asm "xmg_stash", $stashix;
1N/A $sv->domagic($ix) if $sv->MAGICAL;
1N/A}
1N/A
1N/Asub B::PVLV::bsave {
1N/A my ($sv,$ix) = @_;
1N/A my $targix = $sv->TARG->ix;
1N/A $sv->B::PVMG::bsave($ix);
1N/A asm "xlv_targ", $targix;
1N/A asm "xlv_targoff", $sv->TARGOFF;
1N/A asm "xlv_targlen", $sv->TARGLEN;
1N/A asm "xlv_type", $sv->TYPE;
1N/A
1N/A}
1N/A
1N/Asub B::BM::bsave {
1N/A my ($sv,$ix) = @_;
1N/A $sv->B::PVMG::bsave($ix);
1N/A asm "xpv_cur", $sv->CUR;
1N/A asm "xbm_useful", $sv->USEFUL;
1N/A asm "xbm_previous", $sv->PREVIOUS;
1N/A asm "xbm_rare", $sv->RARE;
1N/A}
1N/A
1N/Asub B::IO::bsave {
1N/A my ($io,$ix) = @_;
1N/A my $topix = $io->TOP_GV->ix;
1N/A my $fmtix = $io->FMT_GV->ix;
1N/A my $bottomix = $io->BOTTOM_GV->ix;
1N/A $io->B::PVMG::bsave($ix);
1N/A asm "xio_lines", $io->LINES;
1N/A asm "xio_page", $io->PAGE;
1N/A asm "xio_page_len", $io->PAGE_LEN;
1N/A asm "xio_lines_left", $io->LINES_LEFT;
1N/A asm "xio_top_name", pvix $io->TOP_NAME;
1N/A asm "xio_top_gv", $topix;
1N/A asm "xio_fmt_name", pvix $io->FMT_NAME;
1N/A asm "xio_fmt_gv", $fmtix;
1N/A asm "xio_bottom_name", pvix $io->BOTTOM_NAME;
1N/A asm "xio_bottom_gv", $bottomix;
1N/A asm "xio_subprocess", $io->SUBPROCESS;
1N/A asm "xio_type", ord $io->IoTYPE;
1N/A # asm "xio_flags", ord($io->IoFLAGS) & ~32; # XXX XXX
1N/A}
1N/A
1N/Asub B::CV::bsave {
1N/A my ($cv,$ix) = @_;
1N/A my $stashix = $cv->STASH->ix;
1N/A my $gvix = $cv->GV->ix;
1N/A my $padlistix = $cv->PADLIST->ix;
1N/A my $outsideix = $cv->OUTSIDE->ix;
1N/A my $constix = $cv->CONST ? $cv->XSUBANY->ix : 0;
1N/A my $startix = $cv->START->opwalk;
1N/A my $rootix = $cv->ROOT->ix;
1N/A
1N/A $cv->B::PVMG::bsave($ix);
1N/A asm "xcv_stash", $stashix;
1N/A asm "xcv_start", $startix;
1N/A asm "xcv_root", $rootix;
1N/A asm "xcv_xsubany", $constix;
1N/A asm "xcv_gv", $gvix;
1N/A asm "xcv_file", pvix $cv->FILE if $cv->FILE; # XXX AD
1N/A asm "xcv_padlist", $padlistix;
1N/A asm "xcv_outside", $outsideix;
1N/A asm "xcv_flags", $cv->CvFLAGS;
1N/A asm "xcv_outside_seq", $cv->OUTSIDE_SEQ;
1N/A asm "xcv_depth", $cv->DEPTH;
1N/A}
1N/A
1N/Asub B::FM::bsave {
1N/A my ($form,$ix) = @_;
1N/A
1N/A $form->B::CV::bsave($ix);
1N/A asm "xfm_lines", $form->LINES;
1N/A}
1N/A
1N/Asub B::AV::bsave {
1N/A my ($av,$ix) = @_;
1N/A return $av->B::PVMG::bsave($ix) if $av->MAGICAL;
1N/A my @array = $av->ARRAY;
1N/A $_ = $_->ix for @array;
1N/A my $stashix = $av->SvSTASH->ix;
1N/A
1N/A nice "-AV-",
1N/A asm "ldsv", $varix = $ix unless $ix == $varix;
1N/A asm "av_extend", $av->MAX if $av->MAX >= 0;
1N/A asm "av_pushx", $_ for @array;
1N/A asm "sv_refcnt", $av->REFCNT;
1N/A asm "xav_flags", $av->AvFLAGS;
1N/A asm "xmg_stash", $stashix;
1N/A}
1N/A
1N/Asub B::GV::desired {
1N/A my $gv = shift;
1N/A my ($cv, $form);
1N/A $files{$gv->FILE} && $gv->LINE
1N/A || ${$cv = $gv->CV} && $files{$cv->FILE}
1N/A || ${$form = $gv->FORM} && $files{$form->FILE}
1N/A}
1N/A
1N/Asub B::HV::bwalk {
1N/A my $hv = shift;
1N/A return if $walked{$$hv}++;
1N/A my %stash = $hv->ARRAY;
1N/A while (my($k,$v) = each %stash) {
1N/A if ($v->SvTYPE == SVt_PVGV) {
1N/A my $hash = $v->HV;
1N/A if ($$hash && $hash->NAME) {
1N/A $hash->bwalk;
1N/A }
1N/A $v->ix(1) if desired $v;
1N/A } else {
1N/A nice "[prototype]";
1N/A asm "gv_fetchpvx", cstring $hv->NAME . "::$k";
1N/A $svtab{$$v} = $varix = $tix;
1N/A $v->bsave($tix++);
1N/A asm "sv_flags", $v->FLAGS;
1N/A }
1N/A }
1N/A}
1N/A
1N/A######################################################
1N/A
1N/A
1N/Asub B::OP::bsave_thin {
1N/A my ($op, $ix) = @_;
1N/A my $next = $op->next;
1N/A my $nextix = $optab{$$next};
1N/A $nextix = 0, push @cloop, $op unless defined $nextix;
1N/A if ($ix != $opix) {
1N/A nice '-'.$op->name.'-',
1N/A asm "ldop", $opix = $ix;
1N/A }
1N/A asm "op_next", $nextix;
1N/A asm "op_targ", $op->targ if $op->type; # tricky
1N/A asm "op_flags", $op->flags;
1N/A asm "op_private", $op->private;
1N/A}
1N/A
1N/Asub B::OP::bsave;
1N/A *B::OP::bsave = *B::OP::bsave_thin;
1N/A
1N/Asub B::UNOP::bsave {
1N/A my ($op, $ix) = @_;
1N/A my $name = $op->name;
1N/A my $flags = $op->flags;
1N/A my $first = $op->first;
1N/A my $firstix =
1N/A $name =~ /fl[io]p/
1N/A # that's just neat
1N/A || (!ITHREADS && $name eq 'regcomp')
1N/A # trick for /$a/o in pp_regcomp
1N/A || $name eq 'rv2sv'
1N/A && $op->flags & OPf_MOD
1N/A && $op->private & OPpLVAL_INTRO
1N/A # change #18774 made my life hard
1N/A ? $first->ix
1N/A : 0;
1N/A
1N/A $op->B::OP::bsave($ix);
1N/A asm "op_first", $firstix;
1N/A}
1N/A
1N/Asub B::BINOP::bsave {
1N/A my ($op, $ix) = @_;
1N/A if ($op->name eq 'aassign' && $op->private & B::OPpASSIGN_HASH()) {
1N/A my $last = $op->last;
1N/A my $lastix = do {
1N/A local *B::OP::bsave = *B::OP::bsave_fat;
1N/A local *B::UNOP::bsave = *B::UNOP::bsave_fat;
1N/A $last->ix;
1N/A };
1N/A asm "ldop", $lastix unless $lastix == $opix;
1N/A asm "op_targ", $last->targ;
1N/A $op->B::OP::bsave($ix);
1N/A asm "op_last", $lastix;
1N/A } else {
1N/A $op->B::OP::bsave($ix);
1N/A }
1N/A}
1N/A
1N/A# not needed if no pseudohashes
1N/A
1N/A*B::BINOP::bsave = *B::OP::bsave if VERSION >= 5.009;
1N/A
1N/A# deal with sort / formline
1N/A
1N/Asub B::LISTOP::bsave {
1N/A my ($op, $ix) = @_;
1N/A my $name = $op->name;
1N/A sub blocksort() { OPf_SPECIAL|OPf_STACKED }
1N/A if ($name eq 'sort' && ($op->flags & blocksort) == blocksort) {
1N/A my $first = $op->first;
1N/A my $pushmark = $first->sibling;
1N/A my $rvgv = $pushmark->first;
1N/A my $leave = $rvgv->first;
1N/A
1N/A my $leaveix = $leave->ix;
1N/A
1N/A my $rvgvix = $rvgv->ix;
1N/A asm "ldop", $rvgvix unless $rvgvix == $opix;
1N/A asm "op_first", $leaveix;
1N/A
1N/A my $pushmarkix = $pushmark->ix;
1N/A asm "ldop", $pushmarkix unless $pushmarkix == $opix;
1N/A asm "op_first", $rvgvix;
1N/A
1N/A my $firstix = $first->ix;
1N/A asm "ldop", $firstix unless $firstix == $opix;
1N/A asm "op_sibling", $pushmarkix;
1N/A
1N/A $op->B::OP::bsave($ix);
1N/A asm "op_first", $firstix;
1N/A } elsif ($name eq 'formline') {
1N/A $op->B::UNOP::bsave_fat($ix);
1N/A } else {
1N/A $op->B::OP::bsave($ix);
1N/A }
1N/A}
1N/A
1N/A# fat versions
1N/A
1N/Asub B::OP::bsave_fat {
1N/A my ($op, $ix) = @_;
1N/A my $siblix = $op->sibling->ix;
1N/A
1N/A $op->B::OP::bsave_thin($ix);
1N/A asm "op_sibling", $siblix;
1N/A # asm "op_seq", -1; XXX don't allocate OPs piece by piece
1N/A}
1N/A
1N/Asub B::UNOP::bsave_fat {
1N/A my ($op,$ix) = @_;
1N/A my $firstix = $op->first->ix;
1N/A
1N/A $op->B::OP::bsave($ix);
1N/A asm "op_first", $firstix;
1N/A}
1N/A
1N/Asub B::BINOP::bsave_fat {
1N/A my ($op,$ix) = @_;
1N/A my $last = $op->last;
1N/A my $lastix = $op->last->ix;
1N/A if (VERSION < 5.009 && $op->name eq 'aassign' && $last->name eq 'null') {
1N/A asm "ldop", $lastix unless $lastix == $opix;
1N/A asm "op_targ", $last->targ;
1N/A }
1N/A
1N/A $op->B::UNOP::bsave($ix);
1N/A asm "op_last", $lastix;
1N/A}
1N/A
1N/Asub B::LOGOP::bsave {
1N/A my ($op,$ix) = @_;
1N/A my $otherix = $op->other->ix;
1N/A
1N/A $op->B::UNOP::bsave($ix);
1N/A asm "op_other", $otherix;
1N/A}
1N/A
1N/Asub B::PMOP::bsave {
1N/A my ($op,$ix) = @_;
1N/A my ($rrop, $rrarg, $rstart);
1N/A
1N/A # my $pmnextix = $op->pmnext->ix; # XXX
1N/A
1N/A if (ITHREADS) {
1N/A if ($op->name eq 'subst') {
1N/A $rrop = "op_pmreplroot";
1N/A $rrarg = $op->pmreplroot->ix;
1N/A $rstart = $op->pmreplstart->ix;
1N/A } elsif ($op->name eq 'pushre') {
1N/A $rrop = "op_pmreplrootpo";
1N/A $rrarg = $op->pmreplroot;
1N/A }
1N/A $op->B::BINOP::bsave($ix);
1N/A asm "op_pmstashpv", pvix $op->pmstashpv;
1N/A } else {
1N/A $rrop = "op_pmreplrootgv";
1N/A $rrarg = $op->pmreplroot->ix;
1N/A $rstart = $op->pmreplstart->ix if $op->name eq 'subst';
1N/A my $stashix = $op->pmstash->ix;
1N/A $op->B::BINOP::bsave($ix);
1N/A asm "op_pmstash", $stashix;
1N/A }
1N/A
1N/A asm $rrop, $rrarg if $rrop;
1N/A asm "op_pmreplstart", $rstart if $rstart;
1N/A
1N/A asm "op_pmflags", $op->pmflags;
1N/A asm "op_pmpermflags", $op->pmpermflags;
1N/A asm "op_pmdynflags", $op->pmdynflags;
1N/A # asm "op_pmnext", $pmnextix; # XXX
1N/A asm "newpv", pvstring $op->precomp;
1N/A asm "pregcomp";
1N/A}
1N/A
1N/Asub B::SVOP::bsave {
1N/A my ($op,$ix) = @_;
1N/A my $svix = $op->sv->ix;
1N/A
1N/A $op->B::OP::bsave($ix);
1N/A asm "op_sv", $svix;
1N/A}
1N/A
1N/Asub B::PADOP::bsave {
1N/A my ($op,$ix) = @_;
1N/A
1N/A $op->B::OP::bsave($ix);
1N/A asm "op_padix", $op->padix;
1N/A}
1N/A
1N/Asub B::PVOP::bsave {
1N/A my ($op,$ix) = @_;
1N/A $op->B::OP::bsave($ix);
1N/A return unless my $pv = $op->pv;
1N/A
1N/A if ($op->name eq 'trans') {
1N/A asm "op_pv_tr", join ',', length($pv)/2, unpack("s*", $pv);
1N/A } else {
1N/A asm "newpv", pvstring $pv;
1N/A asm "op_pv";
1N/A }
1N/A}
1N/A
1N/Asub B::LOOP::bsave {
1N/A my ($op,$ix) = @_;
1N/A my $nextix = $op->nextop->ix;
1N/A my $lastix = $op->lastop->ix;
1N/A my $redoix = $op->redoop->ix;
1N/A
1N/A $op->B::BINOP::bsave($ix);
1N/A asm "op_redoop", $redoix;
1N/A asm "op_nextop", $nextix;
1N/A asm "op_lastop", $lastix;
1N/A}
1N/A
1N/Asub B::COP::bsave {
1N/A my ($cop,$ix) = @_;
1N/A my $warnix = $cop->warnings->ix;
1N/A my $ioix = $cop->io->ix;
1N/A if (ITHREADS) {
1N/A $cop->B::OP::bsave($ix);
1N/A asm "cop_stashpv", pvix $cop->stashpv;
1N/A asm "cop_file", pvix $cop->file;
1N/A } else {
1N/A my $stashix = $cop->stash->ix;
1N/A my $fileix = $cop->filegv->ix(1);
1N/A $cop->B::OP::bsave($ix);
1N/A asm "cop_stash", $stashix;
1N/A asm "cop_filegv", $fileix;
1N/A }
1N/A asm "cop_label", pvix $cop->label if $cop->label; # XXX AD
1N/A asm "cop_seq", $cop->cop_seq;
1N/A asm "cop_arybase", $cop->arybase;
1N/A asm "cop_line", $cop->line;
1N/A asm "cop_warnings", $warnix;
1N/A asm "cop_io", $ioix;
1N/A}
1N/A
1N/Asub B::OP::opwalk {
1N/A my $op = shift;
1N/A my $ix = $optab{$$op};
1N/A defined($ix) ? $ix : do {
1N/A my $ix;
1N/A my @oplist = $op->oplist;
1N/A push @cloop, undef;
1N/A $ix = $_->ix while $_ = pop @oplist;
1N/A while ($_ = pop @cloop) {
1N/A asm "ldop", $optab{$$_};
1N/A asm "op_next", $optab{${$_->next}};
1N/A }
1N/A $ix;
1N/A }
1N/A}
1N/A
1N/A#################################################
1N/A
1N/Asub save_cq {
1N/A my $av;
1N/A if (($av=begin_av)->isa("B::AV")) {
1N/A if ($savebegins) {
1N/A for ($av->ARRAY) {
1N/A next unless $_->FILE eq $0;
1N/A asm "push_begin", $_->ix;
1N/A }
1N/A } else {
1N/A for ($av->ARRAY) {
1N/A next unless $_->FILE eq $0;
1N/A # XXX BEGIN { goto A while 1; A: }
1N/A for (my $op = $_->START; $$op; $op = $op->next) {
1N/A next unless $op->name eq 'require' ||
1N/A # this kludge needed for tests
1N/A $op->name eq 'gv' && do {
1N/A my $gv = class($op) eq 'SVOP' ?
1N/A $op->gv :
1N/A (($_->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
1N/A $$gv && $gv->NAME =~ /use_ok|plan/
1N/A };
1N/A asm "push_begin", $_->ix;
1N/A last;
1N/A }
1N/A }
1N/A }
1N/A }
1N/A if (($av=init_av)->isa("B::AV")) {
1N/A for ($av->ARRAY) {
1N/A next unless $_->FILE eq $0;
1N/A asm "push_init", $_->ix;
1N/A }
1N/A }
1N/A if (($av=end_av)->isa("B::AV")) {
1N/A for ($av->ARRAY) {
1N/A next unless $_->FILE eq $0;
1N/A asm "push_end", $_->ix;
1N/A }
1N/A }
1N/A}
1N/A
1N/Asub compile {
1N/A my ($head, $scan, $T_inhinc, $keep_syn);
1N/A my $cwd = '';
1N/A $files{$0} = 1;
1N/A sub keep_syn {
1N/A $keep_syn = 1;
1N/A *B::OP::bsave = *B::OP::bsave_fat;
1N/A *B::UNOP::bsave = *B::UNOP::bsave_fat;
1N/A *B::BINOP::bsave = *B::BINOP::bsave_fat;
1N/A *B::LISTOP::bsave = *B::LISTOP::bsave_fat;
1N/A }
1N/A sub bwarn { print STDERR "Bytecode.pm: @_\n" }
1N/A
1N/A for (@_) {
1N/A if (/^-S/) {
1N/A *newasm = *endasm = sub { };
1N/A *asm = sub { print " @_\n" };
1N/A *nice = sub ($) { print "\n@_\n" };
1N/A } elsif (/^-H/) {
1N/A require ByteLoader;
1N/A $head = "#! $^X\nuse ByteLoader $ByteLoader::VERSION;\n";
1N/A } elsif (/^-k/) {
1N/A keep_syn;
1N/A } elsif (/^-o(.*)$/) {
1N/A open STDOUT, ">$1" or die "open $1: $!";
1N/A } elsif (/^-f(.*)$/) {
1N/A $files{$1} = 1;
1N/A } elsif (/^-s(.*)$/) {
1N/A $scan = length($1) ? $1 : $0;
1N/A } elsif (/^-b/) {
1N/A $savebegins = 1;
1N/A # this is here for the testsuite
1N/A } elsif (/^-TI/) {
1N/A $T_inhinc = 1;
1N/A } elsif (/^-TF(.*)/) {
1N/A my $thatfile = $1;
1N/A *B::COP::file = sub { $thatfile };
1N/A } else {
1N/A bwarn "Ignoring '$_' option";
1N/A }
1N/A }
1N/A if ($scan) {
1N/A my $f;
1N/A if (open $f, $scan) {
1N/A while (<$f>) {
1N/A /^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1;
1N/A /^#/ and next;
1N/A if (/\bgoto\b\s*[^&]/ && !$keep_syn) {
1N/A bwarn "keeping the syntax tree: \"goto\" op found";
1N/A keep_syn;
1N/A }
1N/A }
1N/A } else {
1N/A bwarn "cannot rescan '$scan'";
1N/A }
1N/A close $f;
1N/A }
1N/A binmode STDOUT;
1N/A return sub {
1N/A print $head if $head;
1N/A newasm sub { print @_ };
1N/A
1N/A defstash->bwalk;
1N/A asm "main_start", main_start->opwalk;
1N/A asm "main_root", main_root->ix;
1N/A asm "main_cv", main_cv->ix;
1N/A asm "curpad", (comppadlist->ARRAY)[1]->ix;
1N/A
1N/A asm "signal", cstring "__WARN__" # XXX
1N/A if warnhook->ix;
1N/A asm "incav", inc_gv->AV->ix if $T_inhinc;
1N/A save_cq;
1N/A asm "incav", inc_gv->AV->ix if $T_inhinc;
1N/A asm "dowarn", dowarn;
1N/A
1N/A {
1N/A no strict 'refs';
1N/A nice "<DATA>";
1N/A my $dh = *{defstash->NAME."::DATA"};
1N/A unless (eof $dh) {
1N/A local undef $/;
1N/A asm "data", ord 'D';
1N/A print <$dh>;
1N/A } else {
1N/A asm "ret";
1N/A }
1N/A }
1N/A
1N/A endasm;
1N/A }
1N/A}
1N/A
1N/A1;
1N/A
1N/A=head1 NAME
1N/A
1N/AB::Bytecode - Perl compiler's bytecode backend
1N/A
1N/A=head1 SYNOPSIS
1N/A
1N/AB<perl -MO=Bytecode>[B<,-H>][B<,-o>I<script.plc>] I<script.pl>
1N/A
1N/A=head1 DESCRIPTION
1N/A
1N/ACompiles a Perl script into a bytecode format that could be loaded
1N/Alater by the ByteLoader module and executed as a regular Perl script.
1N/A
1N/A=head1 EXAMPLE
1N/A
1N/A $ perl -MO=Bytecode,-H,-ohi -e 'print "hi!\n"'
1N/A $ perl hi
1N/A hi!
1N/A
1N/A=head1 OPTIONS
1N/A
1N/A=over 4
1N/A
1N/A=item B<-b>
1N/A
1N/ASave all the BEGIN blocks. Normally only BEGIN blocks that C<require>
1N/Aother files (ex. C<use Foo;>) are saved.
1N/A
1N/A=item B<-H>
1N/A
1N/Aprepend a C<use ByteLoader VERSION;> line to the produced bytecode.
1N/A
1N/A=item B<-k>
1N/A
1N/Akeep the syntax tree - it is stripped by default.
1N/A
1N/A=item B<-o>I<outfile>
1N/A
1N/Aput the bytecode in <outfile> instead of dumping it to STDOUT.
1N/A
1N/A=item B<-s>
1N/A
1N/Ascan the script for C<# line ..> directives and for <goto LABEL>
1N/Aexpressions. When gotos are found keep the syntax tree.
1N/A
1N/A=back
1N/A
1N/A=head1 KNOWN BUGS
1N/A
1N/A=over 4
1N/A
1N/A=item *
1N/A
1N/AC<BEGIN { goto A: while 1; A: }> won't even compile.
1N/A
1N/A=item *
1N/A
1N/AC<?...?> and C<reset> do not work as expected.
1N/A
1N/A=item *
1N/A
1N/Avariables in C<(?{ ... })> constructs are not properly scoped.
1N/A
1N/A=item *
1N/A
1N/Ascripts that use source filters will fail miserably.
1N/A
1N/A=back
1N/A
1N/A=head1 NOTICE
1N/A
1N/AThere are also undocumented bugs and options.
1N/A
1N/ATHIS CODE IS HIGHLY EXPERIMENTAL. USE AT YOUR OWN RISK.
1N/A
1N/A=head1 AUTHORS
1N/A
1N/AOriginally written by Malcolm Beattie <mbeattie@sable.ox.ac.uk> and
1N/Amodified by Benjamin Stuhl <sho_pi@hotmail.com>.
1N/A
1N/ARewritten by Enache Adrian <enache@rdslink.ro>, 2003 a.d.
1N/A
1N/A=cut