[p5sagit/p5-mst-13.2.git] / ext / B / B / Bytecode.pm

# B::Bytecode.pm
# Copyright (c) 2003 Enache Adrian. All rights reserved.
# This module is free software; you can redistribute and/or modify
# it under the same terms as Perl itself.

# Based on the original Bytecode.pm module written by Malcolm Beattie.

package B::Bytecode;

use strict;
use Config;
use B qw(class main_cv main_root main_start cstring comppadlist
	defstash curstash begin_av init_av end_av inc_gv warnhook diehook
	dowarn SVt_PVGV SVt_PVHV OPf_SPECIAL OPf_STACKED OPf_MOD
	OPpLVAL_INTRO SVf_FAKE SVf_READONLY);
use B::Asmdata qw(@specialsv_name);
use B::Assembler qw(asm newasm endasm);
no warnings;					# XXX

#################################################

my $ithreads = $Config{'useithreads'} eq 'define';
my ($varix, $opix, $savebegins);
my %strtab = (0,0);
my %svtab = (0,0);
my %optab = (0,0);
my %spectab = (0,0);
my %walked;
my @cloop;
my $tix = 1;
sub asm;
sub nice ($) { }
my %files;

#################################################

sub pvstring {
    my $pv = shift;
    defined($pv) ? cstring ($pv."\0") : "\"\"";
}

sub pvix {
    my $str = pvstring shift;
    my $ix = $strtab{$str};
    defined($ix) ? $ix : do {
	asm "newpv", $str;
	asm "stpv", $strtab{$str} = $tix;
	$tix++;
    }
}

sub B::OP::ix {
    my $op = shift;
    my $ix = $optab{$$op};
    defined($ix) ? $ix : do {
	nice '['.$op->name.']';
	asm "newop", $op->size;
	asm "stop", $optab{$$op} = $opix = $ix = $tix++;
	$op->bsave($ix);
	$ix;
    }
}

sub B::SPECIAL::ix {
    my $spec = shift;
    my $ix = $spectab{$$spec};
    defined($ix) ? $ix : do {
	nice '['.$specialsv_name[$$spec].']';
	asm "ldspecsv", $$spec;
	asm "stsv", $spectab{$$spec} = $varix = $tix;
	$tix++;
    }
}

sub B::SV::ix {
    my $sv = shift;
    my $ix = $svtab{$$sv};
    defined($ix) ? $ix : do {
	nice '['.class($sv).']';
	asm "newsv", $sv->SvTYPE;
	asm "stsv", $svtab{$$sv} = $varix = $ix = $tix++;
	$sv->bsave($ix);
	$ix;
    }
}

sub B::GV::ix {
    my ($gv,$desired) = @_;
    my $ix = $svtab{$$gv};
    defined($ix) ? $ix : do {
	if ($gv->GP) {
	    my ($svix, $avix, $hvix, $cvix, $ioix, $formix);
	    nice "[GV]";
	    my $name = $gv->STASH->NAME . "::" . $gv->NAME;
	    asm "gv_fetchpv", cstring $name;
	    asm "stsv", $svtab{$$gv} = $varix = $ix = $tix++;
	    asm "sv_flags", $gv->FLAGS;
	    asm "sv_refcnt", $gv->REFCNT;
	    asm "xgv_flags", $gv->GvFLAGS;

	    asm "gp_refcnt", $gv->GvREFCNT;
	    asm "load_glob", $ix if $name eq "CORE::GLOBAL::glob";
	    return $ix
		    unless $desired || desired $gv;
	    $svix = $gv->SV->ix;
	    $avix = $gv->AV->ix;
	    $hvix = $gv->HV->ix;

    # TODO: kludge
	    my $cv = $gv->CV;
	    $cvix = $$cv && defined $files{$cv->FILE} ? $cv->ix : 0;
	    my $form = $gv->FORM;
	    $formix = $$form && defined $files{$form->FILE} ? $form->ix : 0;

	    $ioix = $name !~ /STDOUT$/ ? $gv->IO->ix : 0;		# XXX

	    nice "-GV-",
	    asm "ldsv", $varix = $ix unless $ix == $varix;
	    asm "gp_sv", $svix;
	    asm "gp_av", $avix;
	    asm "gp_hv", $hvix;
	    asm "gp_cv", $cvix;
	    asm "gp_io", $ioix;
	    asm "gp_cvgen", $gv->CVGEN;
	    asm "gp_form", $formix;
	    asm "gp_file", pvix $gv->FILE;
	    asm "gp_line", $gv->LINE;
	    asm "formfeed", $svix if $name eq "main::\cL";
	} else {
	    nice "[GV]";
	    asm "newsv", SVt_PVGV;
	    asm "stsv", $svtab{$$gv} = $varix = $ix = $tix++;
	    my $stashix = $gv->STASH->ix;
	    $gv->B::PVMG::bsave($ix);
	    asm "xgv_flags", $gv->GvFLAGS;
	    asm "xgv_stash", $stashix;
	}
	$ix;
    }
}

sub B::HV::ix {
    my $hv = shift;
    my $ix = $svtab{$$hv};
    defined($ix) ? $ix : do {
	my ($ix,$i,@array);
	my $name = $hv->NAME;
	if ($name) {
	    nice "[STASH]";
	    asm "gv_stashpv", cstring $name;
	    asm "stsv", $svtab{$$hv} = $varix = $ix = $tix++;
	    asm "xhv_name", pvix $name;
	    # my $pmrootix = $hv->PMROOT->ix;	# XXX
	    asm "ldsv", $varix = $ix unless $ix == $varix;
	    # asm "xhv_pmroot", $pmrootix;	# XXX
	} else {
	    nice "[HV]";
	    asm "newsv", SVt_PVHV;
	    asm "stsv", $svtab{$$hv} = $varix = $ix = $tix++;
	    my $stashix = $hv->SvSTASH->ix;
	    for (@array = $hv->ARRAY) {
		next if $i = not $i;
		$_ = $_->ix;
	    }
	    nice "-HV-",
	    asm "ldsv", $varix = $ix unless $ix == $varix;
	    ($i = not $i) ? asm ("newpv", pvstring $_) : asm("hv_store", $_)
		for @array;
	    asm "xnv", $hv->NVX;
	    asm "xmg_stash", $stashix;
	}
	asm "sv_refcnt", $hv->REFCNT;
	asm "sv_flags", $hv->FLAGS;
	$ix;
    }
}

sub B::NULL::ix {
    my $sv = shift;
    $$sv ? $sv->B::SV::ix : 0;
}

sub B::NULL::opwalk { 0 }

#################################################

sub B::NULL::bsave {
    my ($sv,$ix) = @_;

    nice '-'.class($sv).'-',
    asm "ldsv", $varix = $ix unless $ix == $varix;
    asm "sv_refcnt", $sv->REFCNT;
    asm "sv_flags", $sv->FLAGS;
}

sub B::SV::bsave;
    *B::SV::bsave = *B::NULL::bsave;

sub B::RV::bsave {
    my ($sv,$ix) = @_;
    my $rvix = $sv->RV->ix;
    $sv->B::NULL::bsave($ix);
    asm "xrv", $rvix;
}

sub B::PV::bsave {
    my ($sv,$ix) = @_;
    $sv->B::NULL::bsave($ix);
    asm "newpv", pvstring $sv->PVBM;
    asm "xpv";
}

sub B::IV::bsave {
    my ($sv,$ix) = @_;
    $sv->B::NULL::bsave($ix);
    asm "xiv", $sv->IVX;
}

sub B::NV::bsave {
    my ($sv,$ix) = @_;
    $sv->B::NULL::bsave($ix);
    asm "xnv", sprintf "%.40g", $sv->NVX;
}

sub B::PVIV::bsave {
    my ($sv,$ix) = @_;
    $sv->POK ?
	$sv->B::PV::bsave($ix):
    $sv->ROK ?
	$sv->B::RV::bsave($ix):
	$sv->B::NULL::bsave($ix);
    asm "xiv", !$ithreads && $sv->FLAGS & (SVf_FAKE|SVf_READONLY) ?
	"0 but true" : $sv->IVX;
}

sub B::PVNV::bsave {
    my ($sv,$ix) = @_;
    $sv->B::PVIV::bsave($ix);
    asm "xnv", sprintf "%.40g", $sv->NVX;
}

sub B::PVMG::domagic {
    my ($sv,$ix) = @_;
    nice '-MAGICAL-';
    my @mglist = $sv->MAGIC;
    my (@mgix, @namix);
    for (@mglist) {
	push @mgix, $_->OBJ->ix;
	push @namix, $_->PTR->ix if $_->LENGTH == B::HEf_SVKEY;
    }

    nice '-'.class($sv).'-',
    asm "ldsv", $varix = $ix unless $ix == $varix;
    for (@mglist) {
	asm "sv_magic", cstring $_->TYPE;
	asm "mg_obj", shift @mgix;
	my $length = $_->LENGTH;
	if ($length == B::HEf_SVKEY) {
	    asm "mg_namex", shift @namix;
	} elsif ($length) {
	    asm "newpv", pvstring $_->PTR;
	    asm "mg_name";
	}
    }
}

sub B::PVMG::bsave {
    my ($sv,$ix) = @_;
    my $stashix = $sv->SvSTASH->ix;
    $sv->B::PVNV::bsave($ix);
    asm "xmg_stash", $stashix;
    $sv->domagic($ix) if $sv->MAGICAL;
}

sub B::PVLV::bsave {
    my ($sv,$ix) = @_;
    my $targix = $sv->TARG->ix;
    $sv->B::PVMG::bsave($ix);
    asm "xlv_targ", $targix;
    asm "xlv_targoff", $sv->TARGOFF;
    asm "xlv_targlen", $sv->TARGLEN;
    asm "xlv_type", $sv->TYPE;

}

sub B::BM::bsave {
    my ($sv,$ix) = @_;
    $sv->B::PVMG::bsave($ix);
    asm "xpv_cur", $sv->CUR;
    asm "xbm_useful", $sv->USEFUL;
    asm "xbm_previous", $sv->PREVIOUS;
    asm "xbm_rare", $sv->RARE;
}

sub B::IO::bsave {
    my ($io,$ix) = @_;
    my $topix = $io->TOP_GV->ix;
    my $fmtix = $io->FMT_GV->ix;
    my $bottomix = $io->BOTTOM_GV->ix;
    $io->B::PVMG::bsave($ix);
    asm "xio_lines", $io->LINES;
    asm "xio_page", $io->PAGE;
    asm "xio_page_len", $io->PAGE_LEN;
    asm "xio_lines_left", $io->LINES_LEFT;
    asm "xio_top_name", pvix $io->TOP_NAME;
    asm "xio_top_gv", $topix;
    asm "xio_fmt_name", pvix $io->FMT_NAME;
    asm "xio_fmt_gv", $fmtix;
    asm "xio_bottom_name", pvix $io->BOTTOM_NAME;
    asm "xio_bottom_gv", $bottomix;
    asm "xio_subprocess", $io->SUBPROCESS;
    asm "xio_type", ord $io->IoTYPE;
    # asm "xio_flags", ord($io->IoFLAGS) & ~32;		# XXX XXX
}

sub B::CV::bsave {
    my ($cv,$ix) = @_;
    my $stashix = $cv->STASH->ix;
    my $startix = $cv->START->opwalk;
    my $rootix = $cv->ROOT->ix;
    my $gvix = $cv->GV->ix;
    my $padlistix = $cv->PADLIST->ix;
    my $outsideix = $cv->OUTSIDE->ix;
    my $constix = $cv->CONST ? $cv->XSUBANY->ix : 0;

    $cv->B::PVMG::bsave($ix);
    asm "xcv_stash", $stashix;
    asm "xcv_start", $startix;
    asm "xcv_root", $rootix;
    asm "xcv_xsubany", $constix;
    asm "xcv_gv", $gvix;
    asm "xcv_file", pvix $cv->FILE if $cv->FILE;	# XXX AD
    asm "xcv_padlist", $padlistix;
    asm "xcv_outside", $outsideix;
    asm "xcv_flags", $cv->CvFLAGS;
    asm "xcv_outside_seq", $cv->OUTSIDE_SEQ;
    asm "xcv_depth", $cv->DEPTH;
}

sub B::FM::bsave {
    my ($form,$ix) = @_;

    $form->B::CV::bsave($ix);
    asm "xfm_lines", $form->LINES;
}

sub B::AV::bsave {
    my ($av,$ix) = @_;
    return $av->B::PVMG::bsave($ix) if $av->MAGICAL;
    my @array = $av->ARRAY;
    $_ = $_->ix for @array;
    my $stashix = $av->SvSTASH->ix;

    nice "-AV-",
    asm "ldsv", $varix = $ix unless $ix == $varix;
    asm "av_extend", $av->MAX;
    asm "av_pushx", $_ for @array;
    asm "sv_refcnt", $av->REFCNT;
    asm "sv_flags", $av->FLAGS;
    asm "xav_flags", $av->AvFLAGS;
    asm "xmg_stash", $stashix;
}

sub B::GV::desired {
    my $gv = shift;
    my ($cv, $form);
    $files{$gv->FILE} && $gv->LINE
    || ${$cv = $gv->CV} && $files{$cv->FILE}
    || ${$form = $gv->FORM} && $files{$form->FILE}
}

sub B::HV::bwalk {
    my $hv = shift;
    return if $walked{$$hv}++;
    my %stash = $hv->ARRAY;
    while (my($k,$v) = each %stash) {
	if ($v->SvTYPE == SVt_PVGV) {
	    my $hash = $v->HV;
	    if ($$hash && $hash->NAME) {
		$hash->bwalk;
	    } 
	    $v->ix(1) if desired $v;
	} else {
	    nice "[prototype]";
	    asm "gv_fetchpv", cstring $hv->NAME . "::$k";
	    asm "stsv", $svtab{$$v} = $varix = $tix;
	    $v->bsave($tix++);
	}
    }
}

######################################################


sub B::OP::bsave_thin {
    my ($op, $ix) = @_;
    my $next = $op->next;
    my $nextix = $optab{$$next};
    $nextix = 0, push @cloop, $op unless defined $nextix;
    if ($ix != $opix) {
	nice '-'.$op->name.'-',
	asm "ldop", $opix = $ix;
    }
    asm "op_type", $op->type;
    asm "op_next", $nextix;
    asm "op_targ", $op->targ if $op->type;		# tricky
    asm "op_flags", $op->flags;
    asm "op_private", $op->private;
}

sub B::OP::bsave;
    *B::OP::bsave = *B::OP::bsave_thin;

sub B::UNOP::bsave {
    my ($op, $ix) = @_;
    my $name = $op->name;
    my $flags = $op->flags;
    my $first = $op->first;
    my $firstix = 
	$name =~ /fl[io]p/
			# that's just neat
    ||	(!$ithreads && $name =~ /regcomp/)
			# trick for /$a/o in pp_regcomp
    ||	$name eq 'rv2sv'
	    && $op->flags & OPf_MOD	
	    && $op->private & OPpLVAL_INTRO
			# change #18774 made my life hard
    ?	$first->ix
    :	0;

    $op->B::OP::bsave($ix);
    asm "op_first", $firstix;
}

sub B::BINOP::bsave;
    *B::BINOP::bsave = *B::OP::bsave;

# deal with sort / formline 

sub B::LISTOP::bsave {
    my ($op, $ix) = @_;
    my $name = $op->name;
    if ($name eq 'sort' && $op->flags & (OPf_SPECIAL|OPf_STACKED)) {
	my $first = $op->first;
	my $firstix = $first->ix;
	my $firstsiblix = do {
	    local *B::UNOP::bsave = *B::UNOP::bsave_fat;
	    local *B::LISTOP::bsave = *B::UNOP::bsave_fat;
	    $first->sibling->ix;
	};
	asm "ldop", $firstix unless $firstix == $opix;
	asm "op_sibling", $firstsiblix;
	$op->B::OP::bsave($ix);
	asm "op_first", $firstix;
    } elsif ($name eq 'formline') {
	$op->B::UNOP::bsave_fat($ix);
    } else {
	$op->B::OP::bsave($ix);
    }
}

# fat versions

sub B::OP::bsave_fat {
    my ($op, $ix) = @_;
    my $siblix = $op->sibling->ix;

    $op->B::OP::bsave_thin($ix);
    asm "op_sibling", $siblix;
    # asm "op_seq", -1;			XXX don't allocate OPs piece by piece
}

sub B::UNOP::bsave_fat {
    my ($op,$ix) = @_;
    my $firstix = $op->first->ix;

    $op->B::OP::bsave($ix);
    asm "op_first", $firstix;
}

sub B::BINOP::bsave_fat {
    my ($op,$ix) = @_;
    my $last = $op->last;
    my $lastix = $op->last->ix;
    if ($] < 5.009 && $op->name eq 'aassign' && $last->name eq 'null') {
	asm "ldop", $lastix unless $lastix == $opix;
	asm "op_targ", $last->targ;
    }

    $op->B::UNOP::bsave($ix);
    asm "op_last", $lastix;
}

sub B::LOGOP::bsave {
    my ($op,$ix) = @_;
    my $otherix = $op->other->ix;

    $op->B::UNOP::bsave($ix);
    asm "op_other", $otherix;
}

sub B::PMOP::bsave {
    my ($op,$ix) = @_;
    my ($rrop, $rrarg, $rstart);

    # my $pmnextix = $op->pmnext->ix;	# XXX

    if ($ithreads) {
	if ($op->name eq 'subst') {
	    $rrop = "op_pmreplroot";
	    $rrarg = $op->pmreplroot->ix;
	    $rstart = $op->pmreplstart->ix;
	} elsif ($op->name eq 'pushre') {
	    $rrop = "op_pmreplrootpo";
	    $rrarg = $op->pmreplroot;
	}
	$op->B::BINOP::bsave($ix);
	asm "op_pmstashpv", pvix $op->pmstashpv;
    } else {
	$rrop = "op_pmreplrootgv";
	$rrarg = $op->pmreplroot->ix;
	$rstart = $op->pmreplstart->ix if $op->name eq 'subst';
	my $stashix = $op->pmstash->ix;
	$op->B::BINOP::bsave($ix);
	asm "op_pmstash", $stashix;
    }

    asm $rrop, $rrarg if $rrop;
    asm "op_pmreplstart", $rstart if $rstart;

    asm "op_pmflags", $op->pmflags;
    asm "op_pmpermflags", $op->pmpermflags;
    asm "op_pmdynflags", $op->pmdynflags;
    # asm "op_pmnext", $pmnextix;	# XXX
    asm "newpv", pvstring $op->precomp;
    asm "pregcomp";
}

sub B::SVOP::bsave {
    my ($op,$ix) = @_;
    my $svix = $op->sv->ix;

    $op->B::OP::bsave($ix);
    asm "op_sv", $svix;
}

sub B::PADOP::bsave {
    my ($op,$ix) = @_;

    $op->B::OP::bsave($ix);
    asm "op_padix", $op->padix;
}

sub B::PVOP::bsave {
    my ($op,$ix) = @_;
    $op->B::OP::bsave($ix);
    return unless my $pv = $op->pv;

    if ($op->name eq 'trans') {
        asm "op_pv_tr", join ',', length($pv)/2, unpack("s*", $pv);
    } else {
        asm "newpv", pvstring $pv;
        asm "op_pv";
    }
}

sub B::LOOP::bsave {
    my ($op,$ix) = @_;
    my $nextix = $op->nextop->ix;
    my $lastix = $op->lastop->ix;
    my $redoix = $op->redoop->ix;

    $op->B::BINOP::bsave($ix);
    asm "op_redoop", $redoix;
    asm "op_nextop", $nextix;
    asm "op_lastop", $lastix;
}

sub B::COP::bsave {
    my ($cop,$ix) = @_;
    my $warnix = $cop->warnings->ix;
    my $ioix = $cop->io->ix;
    if ($ithreads) {
	$cop->B::OP::bsave($ix);
	asm "cop_stashpv", pvix $cop->stashpv;
	asm "cop_file", pvix $cop->file;
    } else {
    	my $stashix = $cop->stash->ix;
    	my $fileix = $cop->filegv->ix(1);
	$cop->B::OP::bsave($ix);
	asm "cop_stash", $stashix;
	asm "cop_filegv", $fileix;
    }
    asm "cop_label", pvix $cop->label if $cop->label;	# XXX AD
    asm "cop_seq", $cop->cop_seq;
    asm "cop_arybase", $cop->arybase;
    asm "cop_line", $cop->line;
    asm "cop_warnings", $warnix;
    asm "cop_io", $ioix;
}

sub B::OP::opwalk {
    my $op = shift;
    my $ix = $optab{$$op};
    defined($ix) ? $ix : do {
	my $ix;
	my @oplist = $op->oplist;
	push @cloop, undef;
	$ix = $_->ix while $_ = pop @oplist;
	while ($_ = pop @cloop) {
	    asm "ldop", $optab{$$_};
	    asm "op_next", $optab{${$_->next}};
	}
	$ix;
    }
}

#################################################

sub save_cq {
    my $av;
    if (($av=begin_av)->isa("B::AV")) {
	if ($savebegins) {
	    for ($av->ARRAY) {
		next unless $_->FILE eq $0;
		asm "push_begin", $_->ix;
	    }
	} else {
	    for ($av->ARRAY) {
		next unless $_->FILE eq $0;
		# XXX BEGIN { exit while 1 }
		for (my $op = $_->START; $$op; $op = $op->next) {
		    next unless $op->name =~ /require/;
		    asm "push_begin", $_->ix;
		    last;
		}
	    }
	}
    }
    if (($av=init_av)->isa("B::AV")) {
	for ($av->ARRAY) {
	    next unless $_->FILE eq $0;
	    asm "push_init", $_->ix;
	}
    }
    if (($av=end_av)->isa("B::AV")) {
	for ($av->ARRAY) {
	    next unless $_->FILE eq $0;
	    asm "push_end", $_->ix;
	}
    }
}

sub compile {
    my ($head, $scan, $T_inhinc, $T_thatfile, $keep_syn);
    my $cwd = '';
    $files{$0} = 1;
    sub keep_syn {
	$keep_syn = 1;
	*B::OP::bsave = *B::OP::bsave_fat;
	*B::UNOP::bsave = *B::UNOP::bsave_fat;
	*B::BINOP::bsave = *B::BINOP::bsave_fat;
	*B::LISTOP::bsave = *B::LISTOP::bsave_fat;
    }
    sub bwarn { print STDERR "Bytecode.pm: @_\n" }

    for (@_) {
	if (/^-S/) {
	    *newasm = *endasm = sub { };
	    *asm = sub { print "    @_\n" };
	    *nice = sub ($) { print "\n@_\n" };
	} elsif (/^-H/) {
	    require ByteLoader;
	    $head = "#! $^X\nuse ByteLoader $ByteLoader::VERSION;\n";
	} elsif (/^-k/) {
	    keep_syn;
	} elsif (/^-o(.*)$/) {
	    my $ofile = $1;
	    open STDOUT, ">$ofile" or die "open $ofile: $!";
	    *B::COP::file = sub { $ofile } if $T_thatfile;
	} elsif (/^-f(.*)$/) {
	    $files{$1} = 1;
	} elsif (/^-s/) {
	    $scan = 1;
	} elsif (/^-b/) {
	    $savebegins = 1;
    # these are here for the testsuite
	} elsif (/^-TD(.*)/) {
	    $T_inhinc = 1;
	    $cwd = $1;
	} elsif (/^-TF/) {
	    $T_thatfile = 1;
	} else {
	    bwarn "Ignoring '$_' option";
	}
    }
    if ($scan) {
	for(keys %files) {
	    my $f;
	    # KLUDGE
	    open($f, $_) or open ($f, "$cwd/$_")
		or bwarn("cannot rescan '$_'"), next;
	    while (<$f>) {
		/^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1;
		/^#/ and next;
		if (/\bgoto\b/ && !$keep_syn) {
		    bwarn "keeping the syntax tree: \"goto\" op found";
		    keep_syn;
		}
	    }
	    close $f;
	}
    }
    binmode STDOUT;
    return sub {
	print $head if $head;
	newasm sub { print @_ };

	defstash->bwalk;
	asm "main_start", main_start->opwalk;
	asm "main_root", main_root->ix;
	asm "main_cv", main_cv->ix;
	asm "curpad", (comppadlist->ARRAY)[1]->ix;

	asm "signal", cstring "__WARN__"		# XXX
	    if warnhook->ix;
	asm "incav", inc_gv->AV->ix if $T_inhinc;
	save_cq;
	asm "incav", inc_gv->AV->ix if $T_inhinc;
	asm "dowarn", dowarn;

	{
	    no strict 'refs';
	    nice "<DATA>";
	    my $dh = *{defstash->NAME."::DATA"};
	    local undef $/;
	    if (length (my $data = <$dh>)) {
		asm "data", ord 'D';
		print $data;
	    } else {
		asm "ret";
	    }
	}

	endasm;
    }
}

1;
Commit	Line	Data
1df34986	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.
059a8bb7	7
1df34986	8	package B::Bytecode;
28b605d8	9
a798dbf2	10	use strict;
1df34986	11	use Config;
	12	use B qw(class main_cv main_root main_start cstring comppadlist
	13	defstash curstash begin_av init_av end_av inc_gv warnhook diehook
	14	dowarn SVt_PVGV SVt_PVHV OPf_SPECIAL OPf_STACKED OPf_MOD
	15	OPpLVAL_INTRO SVf_FAKE SVf_READONLY);
	16	use B::Asmdata qw(@specialsv_name);
	17	use B::Assembler qw(asm newasm endasm);
	18	no warnings; # XXX
	19
	20	#################################################
	21
	22	my $ithreads = $Config{'useithreads'} eq 'define';
	23	my ($varix, $opix, $savebegins);
	24	my %strtab = (0,0);
	25	my %svtab = (0,0);
	26	my %optab = (0,0);
	27	my %spectab = (0,0);
	28	my %walked;
	29	my @cloop;
	30	my $tix = 1;
	31	sub asm;
	32	sub nice ($) { }
	33	my %files;
	34
	35	#################################################
059a8bb7	36
1df34986	37	sub pvstring {
	38	my $pv = shift;
	39	defined($pv) ? cstring ($pv."\0") : "\"\"";
059a8bb7	40	}
a798dbf2	41
1df34986	42	sub pvix {
	43	my $str = pvstring shift;
	44	my $ix = $strtab{$str};
	45	defined($ix) ? $ix : do {
	46	asm "newpv", $str;
	47	asm "stpv", $strtab{$str} = $tix;
	48	$tix++;
a798dbf2	49	}
	50	}
	51
1df34986	52	sub B::OP::ix {
	53	my $op = shift;
	54	my $ix = $optab{$$op};
	55	defined($ix) ? $ix : do {
	56	nice '['.$op->name.']';
	57	asm "newop", $op->size;
	58	asm "stop", $optab{$$op} = $opix = $ix = $tix++;
	59	$op->bsave($ix);
	60	$ix;
a798dbf2	61	}
	62	}
	63
1df34986	64	sub B::SPECIAL::ix {
	65	my $spec = shift;
	66	my $ix = $spectab{$$spec};
	67	defined($ix) ? $ix : do {
	68	nice '['.$specialsv_name[$$spec].']';
	69	asm "ldspecsv", $$spec;
	70	asm "stsv", $spectab{$$spec} = $varix = $tix;
	71	$tix++;
	72	}
a798dbf2	73	}
a798dbf2	74
1df34986	75	sub B::SV::ix {
	76	my $sv = shift;
	77	my $ix = $svtab{$$sv};
	78	defined($ix) ? $ix : do {
	79	nice '['.class($sv).']';
	80	asm "newsv", $sv->SvTYPE;
	81	asm "stsv", $svtab{$$sv} = $varix = $ix = $tix++;
	82	$sv->bsave($ix);
	83	$ix;
	84	}
	85	}
	86
	87	sub B::GV::ix {
	88	my ($gv,$desired) = @_;
	89	my $ix = $svtab{$$gv};
	90	defined($ix) ? $ix : do {
	91	if ($gv->GP) {
	92	my ($svix, $avix, $hvix, $cvix, $ioix, $formix);
	93	nice "[GV]";
	94	my $name = $gv->STASH->NAME . "::" . $gv->NAME;
	95	asm "gv_fetchpv", cstring $name;
	96	asm "stsv", $svtab{$$gv} = $varix = $ix = $tix++;
	97	asm "sv_flags", $gv->FLAGS;
	98	asm "sv_refcnt", $gv->REFCNT;
	99	asm "xgv_flags", $gv->GvFLAGS;
	100
	101	asm "gp_refcnt", $gv->GvREFCNT;
	102	asm "load_glob", $ix if $name eq "CORE::GLOBAL::glob";
	103	return $ix
	104	unless $desired \|\| desired $gv;
	105	$svix = $gv->SV->ix;
	106	$avix = $gv->AV->ix;
	107	$hvix = $gv->HV->ix;
	108
	109	# TODO: kludge
	110	my $cv = $gv->CV;
	111	$cvix = $$cv && defined $files{$cv->FILE} ? $cv->ix : 0;
	112	my $form = $gv->FORM;
	113	$formix = $$form && defined $files{$form->FILE} ? $form->ix : 0;
	114
	115	$ioix = $name !~ /STDOUT$/ ? $gv->IO->ix : 0; # XXX
	116
	117	nice "-GV-",
	118	asm "ldsv", $varix = $ix unless $ix == $varix;
	119	asm "gp_sv", $svix;
	120	asm "gp_av", $avix;
	121	asm "gp_hv", $hvix;
	122	asm "gp_cv", $cvix;
	123	asm "gp_io", $ioix;
	124	asm "gp_cvgen", $gv->CVGEN;
	125	asm "gp_form", $formix;
	126	asm "gp_file", pvix $gv->FILE;
	127	asm "gp_line", $gv->LINE;
	128	asm "formfeed", $svix if $name eq "main::\cL";
	129	} else {
	130	nice "[GV]";
	131	asm "newsv", SVt_PVGV;
	132	asm "stsv", $svtab{$$gv} = $varix = $ix = $tix++;
	133	my $stashix = $gv->STASH->ix;
	134	$gv->B::PVMG::bsave($ix);
	135	asm "xgv_flags", $gv->GvFLAGS;
	136	asm "xgv_stash", $stashix;
	137	}
	138	$ix;
139	}
a798dbf2	140	}
a798dbf2	141
1df34986	142	sub B::HV::ix {
	143	my $hv = shift;
	144	my $ix = $svtab{$$hv};
	145	defined($ix) ? $ix : do {
	146	my ($ix,$i,@array);
	147	my $name = $hv->NAME;
	148	if ($name) {
	149	nice "[STASH]";
	150	asm "gv_stashpv", cstring $name;
	151	asm "stsv", $svtab{$$hv} = $varix = $ix = $tix++;
	152	asm "xhv_name", pvix $name;
	153	# my $pmrootix = $hv->PMROOT->ix; # XXX
	154	asm "ldsv", $varix = $ix unless $ix == $varix;
	155	# asm "xhv_pmroot", $pmrootix; # XXX
	156	} else {
	157	nice "[HV]";
	158	asm "newsv", SVt_PVHV;
	159	asm "stsv", $svtab{$$hv} = $varix = $ix = $tix++;
	160	my $stashix = $hv->SvSTASH->ix;
	161	for (@array = $hv->ARRAY) {
	162	next if $i = not $i;
	163	$_ = $_->ix;
	164	}
	165	nice "-HV-",
	166	asm "ldsv", $varix = $ix unless $ix == $varix;
	167	($i = not $i) ? asm ("newpv", pvstring $_) : asm("hv_store", $_)
	168	for @array;
	169	asm "xnv", $hv->NVX;
	170	asm "xmg_stash", $stashix;
	171	}
	172	asm "sv_refcnt", $hv->REFCNT;
	173	asm "sv_flags", $hv->FLAGS;
	174	$ix;
a798dbf2	175	}
	176	}
	177
1df34986	178	sub B::NULL::ix {
	179	my $sv = shift;
	180	$$sv ? $sv->B::SV::ix : 0;
059a8bb7	181	}
059a8bb7	182
1df34986	183	sub B::NULL::opwalk { 0 }
a798dbf2	184
1df34986	185	#################################################
a798dbf2	186
1df34986	187	sub B::NULL::bsave {
1df34986	188	my ($sv,$ix) = @_;
059a8bb7	189
1df34986	190	nice '-'.class($sv).'-',
	191	asm "ldsv", $varix = $ix unless $ix == $varix;
	192	asm "sv_refcnt", $sv->REFCNT;
	193	asm "sv_flags", $sv->FLAGS;
a798dbf2	194	}
a798dbf2	195
1df34986	196	sub B::SV::bsave;
1df34986	197	B::SV::bsave = B::NULL::bsave;
a798dbf2	198
1df34986	199	sub B::RV::bsave {
	200	my ($sv,$ix) = @_;
	201	my $rvix = $sv->RV->ix;
	202	$sv->B::NULL::bsave($ix);
	203	asm "xrv", $rvix;
a798dbf2	204	}
a798dbf2	205
1df34986	206	sub B::PV::bsave {
	207	my ($sv,$ix) = @_;
	208	$sv->B::NULL::bsave($ix);
	209	asm "newpv", pvstring $sv->PVBM;
	210	asm "xpv";
a798dbf2	211	}
a798dbf2	212
1df34986	213	sub B::IV::bsave {
	214	my ($sv,$ix) = @_;
	215	$sv->B::NULL::bsave($ix);
	216	asm "xiv", $sv->IVX;
a798dbf2	217	}
a798dbf2	218
1df34986	219	sub B::NV::bsave {
	220	my ($sv,$ix) = @_;
	221	$sv->B::NULL::bsave($ix);
	222	asm "xnv", sprintf "%.40g", $sv->NVX;
a798dbf2	223	}
a798dbf2	224
1df34986	225	sub B::PVIV::bsave {
	226	my ($sv,$ix) = @_;
	227	$sv->POK ?
	228	$sv->B::PV::bsave($ix):
	229	$sv->ROK ?
	230	$sv->B::RV::bsave($ix):
	231	$sv->B::NULL::bsave($ix);
	232	asm "xiv", !$ithreads && $sv->FLAGS & (SVf_FAKE\|SVf_READONLY) ?
	233	"0 but true" : $sv->IVX;
a798dbf2	234	}
a798dbf2	235
1df34986	236	sub B::PVNV::bsave {
	237	my ($sv,$ix) = @_;
	238	$sv->B::PVIV::bsave($ix);
	239	asm "xnv", sprintf "%.40g", $sv->NVX;
a798dbf2	240	}
a798dbf2	241
1df34986	242	sub B::PVMG::domagic {
	243	my ($sv,$ix) = @_;
	244	nice '-MAGICAL-';
	245	my @mglist = $sv->MAGIC;
	246	my (@mgix, @namix);
	247	for (@mglist) {
	248	push @mgix, $_->OBJ->ix;
	249	push @namix, $_->PTR->ix if $_->LENGTH == B::HEf_SVKEY;
a798dbf2	250	}
a798dbf2	251
1df34986	252	nice '-'.class($sv).'-',
	253	asm "ldsv", $varix = $ix unless $ix == $varix;
	254	for (@mglist) {
	255	asm "sv_magic", cstring $_->TYPE;
	256	asm "mg_obj", shift @mgix;
	257	my $length = $_->LENGTH;
	258	if ($length == B::HEf_SVKEY) {
	259	asm "mg_namex", shift @namix;
	260	} elsif ($length) {
	261	asm "newpv", pvstring $_->PTR;
	262	asm "mg_name";
	263	}
a798dbf2	264	}
	265	}
	266
1df34986	267	sub B::PVMG::bsave {
	268	my ($sv,$ix) = @_;
	269	my $stashix = $sv->SvSTASH->ix;
	270	$sv->B::PVNV::bsave($ix);
	271	asm "xmg_stash", $stashix;
	272	$sv->domagic($ix) if $sv->MAGICAL;
	273	}
	274
	275	sub B::PVLV::bsave {
	276	my ($sv,$ix) = @_;
	277	my $targix = $sv->TARG->ix;
	278	$sv->B::PVMG::bsave($ix);
	279	asm "xlv_targ", $targix;
	280	asm "xlv_targoff", $sv->TARGOFF;
	281	asm "xlv_targlen", $sv->TARGLEN;
	282	asm "xlv_type", $sv->TYPE;
	283
	284	}
	285
	286	sub B::BM::bsave {
	287	my ($sv,$ix) = @_;
	288	$sv->B::PVMG::bsave($ix);
	289	asm "xpv_cur", $sv->CUR;
	290	asm "xbm_useful", $sv->USEFUL;
	291	asm "xbm_previous", $sv->PREVIOUS;
	292	asm "xbm_rare", $sv->RARE;
	293	}
	294
	295	sub B::IO::bsave {
	296	my ($io,$ix) = @_;
	297	my $topix = $io->TOP_GV->ix;
	298	my $fmtix = $io->FMT_GV->ix;
	299	my $bottomix = $io->BOTTOM_GV->ix;
	300	$io->B::PVMG::bsave($ix);
	301	asm "xio_lines", $io->LINES;
	302	asm "xio_page", $io->PAGE;
	303	asm "xio_page_len", $io->PAGE_LEN;
	304	asm "xio_lines_left", $io->LINES_LEFT;
	305	asm "xio_top_name", pvix $io->TOP_NAME;
	306	asm "xio_top_gv", $topix;
	307	asm "xio_fmt_name", pvix $io->FMT_NAME;
	308	asm "xio_fmt_gv", $fmtix;
	309	asm "xio_bottom_name", pvix $io->BOTTOM_NAME;
	310	asm "xio_bottom_gv", $bottomix;
	311	asm "xio_subprocess", $io->SUBPROCESS;
	312	asm "xio_type", ord $io->IoTYPE;
	313	# asm "xio_flags", ord($io->IoFLAGS) & ~32; # XXX XXX
	314	}
	315
	316	sub B::CV::bsave {
	317	my ($cv,$ix) = @_;
	318	my $stashix = $cv->STASH->ix;
	319	my $startix = $cv->START->opwalk;
	320	my $rootix = $cv->ROOT->ix;
	321	my $gvix = $cv->GV->ix;
	322	my $padlistix = $cv->PADLIST->ix;
	323	my $outsideix = $cv->OUTSIDE->ix;
	324	my $constix = $cv->CONST ? $cv->XSUBANY->ix : 0;
	325
	326	$cv->B::PVMG::bsave($ix);
	327	asm "xcv_stash", $stashix;
	328	asm "xcv_start", $startix;
	329	asm "xcv_root", $rootix;
	330	asm "xcv_xsubany", $constix;
331	asm "xcv_gv", $gvix;
332	asm "xcv_file", pvix $cv->FILE if $cv->FILE; # XXX AD
333	asm "xcv_padlist", $padlistix;
334	asm "xcv_outside", $outsideix;
335	asm "xcv_flags", $cv->CvFLAGS;
336	asm "xcv_outside_seq", $cv->OUTSIDE_SEQ;
337	asm "xcv_depth", $cv->DEPTH;
338	}
339
340	sub B::FM::bsave {
341	my ($form,$ix) = @_;
342
343	$form->B::CV::bsave($ix);
344	asm "xfm_lines", $form->LINES;
345	}
346
347	sub B::AV::bsave {
348	my ($av,$ix) = @_;
349	return $av->B::PVMG::bsave($ix) if $av->MAGICAL;
350	my @array = $av->ARRAY;
351	$_ = $_->ix for @array;
352	my $stashix = $av->SvSTASH->ix;
353
354	nice "-AV-",
355	asm "ldsv", $varix = $ix unless $ix == $varix;
356	asm "av_extend", $av->MAX;
357	asm "av_pushx", $_ for @array;
358	asm "sv_refcnt", $av->REFCNT;
359	asm "sv_flags", $av->FLAGS;
360	asm "xav_flags", $av->AvFLAGS;
361	asm "xmg_stash", $stashix;
362	}
363
364	sub B::GV::desired {
365	my $gv = shift;
366	my ($cv, $form);
367	$files{$gv->FILE} && $gv->LINE
368	\|\| ${$cv = $gv->CV} && $files{$cv->FILE}
369	\|\| ${$form = $gv->FORM} && $files{$form->FILE}
a798dbf2	370	}
a798dbf2	371
1df34986	372	sub B::HV::bwalk {
	373	my $hv = shift;
	374	return if $walked{$$hv}++;
	375	my %stash = $hv->ARRAY;
	376	while (my($k,$v) = each %stash) {
	377	if ($v->SvTYPE == SVt_PVGV) {
	378	my $hash = $v->HV;
	379	if ($$hash && $hash->NAME) {
	380	$hash->bwalk;
	381	}
	382	$v->ix(1) if desired $v;
	383	} else {
	384	nice "[prototype]";
	385	asm "gv_fetchpv", cstring $hv->NAME . "::$k";
	386	asm "stsv", $svtab{$$v} = $varix = $tix;
	387	$v->bsave($tix++);
	388	}
	389	}
a798dbf2	390	}
a798dbf2	391
1df34986	392	######################################################
a798dbf2	393
a798dbf2	394
1df34986	395	sub B::OP::bsave_thin {
	396	my ($op, $ix) = @_;
	397	my $next = $op->next;
	398	my $nextix = $optab{$$next};
	399	$nextix = 0, push @cloop, $op unless defined $nextix;
	400	if ($ix != $opix) {
	401	nice '-'.$op->name.'-',
	402	asm "ldop", $opix = $ix;
a798dbf2	403	}
1df34986	404	asm "op_type", $op->type;
	405	asm "op_next", $nextix;
	406	asm "op_targ", $op->targ if $op->type; # tricky
	407	asm "op_flags", $op->flags;
	408	asm "op_private", $op->private;
a798dbf2	409	}
a798dbf2	410
1df34986	411	sub B::OP::bsave;
1df34986	412	B::OP::bsave = B::OP::bsave_thin;
a798dbf2	413
1df34986	414	sub B::UNOP::bsave {
	415	my ($op, $ix) = @_;
	416	my $name = $op->name;
	417	my $flags = $op->flags;
	418	my $first = $op->first;
	419	my $firstix =
	420	$name =~ /fl[io]p/
	421	# that's just neat
	422	\|\| (!$ithreads && $name =~ /regcomp/)
	423	# trick for /$a/o in pp_regcomp
	424	\|\| $name eq 'rv2sv'
	425	&& $op->flags & OPf_MOD
	426	&& $op->private & OPpLVAL_INTRO
	427	# change #18774 made my life hard
	428	? $first->ix
	429	: 0;
	430
	431	$op->B::OP::bsave($ix);
	432	asm "op_first", $firstix;
	433	}
	434
	435	sub B::BINOP::bsave;
	436	B::BINOP::bsave = B::OP::bsave;
	437
	438	# deal with sort / formline
	439
	440	sub B::LISTOP::bsave {
	441	my ($op, $ix) = @_;
	442	my $name = $op->name;
	443	if ($name eq 'sort' && $op->flags & (OPf_SPECIAL\|OPf_STACKED)) {
	444	my $first = $op->first;
	445	my $firstix = $first->ix;
	446	my $firstsiblix = do {
	447	local B::UNOP::bsave = B::UNOP::bsave_fat;
	448	local B::LISTOP::bsave = B::UNOP::bsave_fat;
	449	$first->sibling->ix;
	450	};
	451	asm "ldop", $firstix unless $firstix == $opix;
	452	asm "op_sibling", $firstsiblix;
	453	$op->B::OP::bsave($ix);
	454	asm "op_first", $firstix;
	455	} elsif ($name eq 'formline') {
	456	$op->B::UNOP::bsave_fat($ix);
a798dbf2	457	} else {
1df34986	458	$op->B::OP::bsave($ix);
a798dbf2	459	}
a798dbf2	460	}
a798dbf2	461
1df34986	462	# fat versions
a798dbf2	463
1df34986	464	sub B::OP::bsave_fat {
	465	my ($op, $ix) = @_;
	466	my $siblix = $op->sibling->ix;
a798dbf2	467
1df34986	468	$op->B::OP::bsave_thin($ix);
	469	asm "op_sibling", $siblix;
	470	# asm "op_seq", -1; XXX don't allocate OPs piece by piece
a798dbf2	471	}
a798dbf2	472
1df34986	473	sub B::UNOP::bsave_fat {
	474	my ($op,$ix) = @_;
	475	my $firstix = $op->first->ix;
a798dbf2	476
1df34986	477	$op->B::OP::bsave($ix);
1df34986	478	asm "op_first", $firstix;
a798dbf2	479	}
a798dbf2	480
1df34986	481	sub B::BINOP::bsave_fat {
	482	my ($op,$ix) = @_;
	483	my $last = $op->last;
	484	my $lastix = $op->last->ix;
	485	if ($] < 5.009 && $op->name eq 'aassign' && $last->name eq 'null') {
	486	asm "ldop", $lastix unless $lastix == $opix;
	487	asm "op_targ", $last->targ;
a798dbf2	488	}
a798dbf2	489
1df34986	490	$op->B::UNOP::bsave($ix);
1df34986	491	asm "op_last", $lastix;
a798dbf2	492	}
a798dbf2	493
1df34986	494	sub B::LOGOP::bsave {
	495	my ($op,$ix) = @_;
	496	my $otherix = $op->other->ix;
a798dbf2	497
1df34986	498	$op->B::UNOP::bsave($ix);
1df34986	499	asm "op_other", $otherix;
a798dbf2	500	}
a798dbf2	501
1df34986	502	sub B::PMOP::bsave {
	503	my ($op,$ix) = @_;
	504	my ($rrop, $rrarg, $rstart);
059a8bb7	505
1df34986	506	# my $pmnextix = $op->pmnext->ix; # XXX
059a8bb7	507
1df34986	508	if ($ithreads) {
	509	if ($op->name eq 'subst') {
	510	$rrop = "op_pmreplroot";
	511	$rrarg = $op->pmreplroot->ix;
	512	$rstart = $op->pmreplstart->ix;
	513	} elsif ($op->name eq 'pushre') {
	514	$rrop = "op_pmreplrootpo";
	515	$rrarg = $op->pmreplroot;
a798dbf2	516	}
1df34986	517	$op->B::BINOP::bsave($ix);
	518	asm "op_pmstashpv", pvix $op->pmstashpv;
	519	} else {
	520	$rrop = "op_pmreplrootgv";
	521	$rrarg = $op->pmreplroot->ix;
	522	$rstart = $op->pmreplstart->ix if $op->name eq 'subst';
	523	my $stashix = $op->pmstash->ix;
	524	$op->B::BINOP::bsave($ix);
	525	asm "op_pmstash", $stashix;
a798dbf2	526	}
1df34986	527
	528	asm $rrop, $rrarg if $rrop;
	529	asm "op_pmreplstart", $rstart if $rstart;
	530
	531	asm "op_pmflags", $op->pmflags;
	532	asm "op_pmpermflags", $op->pmpermflags;
	533	asm "op_pmdynflags", $op->pmdynflags;
	534	# asm "op_pmnext", $pmnextix; # XXX
	535	asm "newpv", pvstring $op->precomp;
	536	asm "pregcomp";
a798dbf2	537	}
a798dbf2	538
1df34986	539	sub B::SVOP::bsave {
	540	my ($op,$ix) = @_;
	541	my $svix = $op->sv->ix;
	542
	543	$op->B::OP::bsave($ix);
	544	asm "op_sv", $svix;
a798dbf2	545	}
a798dbf2	546
1df34986	547	sub B::PADOP::bsave {
	548	my ($op,$ix) = @_;
	549
	550	$op->B::OP::bsave($ix);
	551	asm "op_padix", $op->padix;
a798dbf2	552	}
a798dbf2	553
1df34986	554	sub B::PVOP::bsave {
	555	my ($op,$ix) = @_;
	556	$op->B::OP::bsave($ix);
	557	return unless my $pv = $op->pv;
	558
	559	if ($op->name eq 'trans') {
	560	asm "op_pv_tr", join ',', length($pv)/2, unpack("s*", $pv);
	561	} else {
	562	asm "newpv", pvstring $pv;
	563	asm "op_pv";
a798dbf2	564	}
a798dbf2	565	}
a798dbf2	566
1df34986	567	sub B::LOOP::bsave {
	568	my ($op,$ix) = @_;
	569	my $nextix = $op->nextop->ix;
	570	my $lastix = $op->lastop->ix;
	571	my $redoix = $op->redoop->ix;
	572
	573	$op->B::BINOP::bsave($ix);
	574	asm "op_redoop", $redoix;
	575	asm "op_nextop", $nextix;
	576	asm "op_lastop", $lastix;
a798dbf2	577	}
a798dbf2	578
1df34986	579	sub B::COP::bsave {
	580	my ($cop,$ix) = @_;
	581	my $warnix = $cop->warnings->ix;
	582	my $ioix = $cop->io->ix;
	583	if ($ithreads) {
	584	$cop->B::OP::bsave($ix);
	585	asm "cop_stashpv", pvix $cop->stashpv;
	586	asm "cop_file", pvix $cop->file;
	587	} else {
	588	my $stashix = $cop->stash->ix;
	589	my $fileix = $cop->filegv->ix(1);
	590	$cop->B::OP::bsave($ix);
	591	asm "cop_stash", $stashix;
	592	asm "cop_filegv", $fileix;
a798dbf2	593	}
1df34986	594	asm "cop_label", pvix $cop->label if $cop->label; # XXX AD
	595	asm "cop_seq", $cop->cop_seq;
	596	asm "cop_arybase", $cop->arybase;
	597	asm "cop_line", $cop->line;
	598	asm "cop_warnings", $warnix;
	599	asm "cop_io", $ioix;
a798dbf2	600	}
a798dbf2	601
1df34986	602	sub B::OP::opwalk {
	603	my $op = shift;
	604	my $ix = $optab{$$op};
	605	defined($ix) ? $ix : do {
	606	my $ix;
	607	my @oplist = $op->oplist;
	608	push @cloop, undef;
	609	$ix = $_->ix while $_ = pop @oplist;
	610	while ($_ = pop @cloop) {
	611	asm "ldop", $optab{$$_};
	612	asm "op_next", $optab{${$_->next}};
a798dbf2	613	}
1df34986	614	$ix;
a798dbf2	615	}
	616	}
	617
1df34986	618	#################################################
	619
	620	sub save_cq {
	621	my $av;
	622	if (($av=begin_av)->isa("B::AV")) {
	623	if ($savebegins) {
	624	for ($av->ARRAY) {
	625	next unless $_->FILE eq $0;
	626	asm "push_begin", $_->ix;
	627	}
	628	} else {
	629	for ($av->ARRAY) {
	630	next unless $_->FILE eq $0;
	631	# XXX BEGIN { exit while 1 }
	632	for (my $op = $_->START; $$op; $op = $op->next) {
	633	next unless $op->name =~ /require/;
	634	asm "push_begin", $_->ix;
	635	last;
059a8bb7	636	}
059a8bb7	637	}
059a8bb7	638	}
a798dbf2	639	}
1df34986	640	if (($av=init_av)->isa("B::AV")) {
	641	for ($av->ARRAY) {
	642	next unless $_->FILE eq $0;
	643	asm "push_init", $_->ix;
059a8bb7	644	}
059a8bb7	645	}
1df34986	646	if (($av=end_av)->isa("B::AV")) {
	647	for ($av->ARRAY) {
	648	next unless $_->FILE eq $0;
	649	asm "push_end", $_->ix;
059a8bb7	650	}
a798dbf2	651	}
	652	}
	653
a798dbf2	654	sub compile {
1df34986	655	my ($head, $scan, $T_inhinc, $T_thatfile, $keep_syn);
	656	my $cwd = '';
	657	$files{$0} = 1;
	658	sub keep_syn {
	659	$keep_syn = 1;
	660	B::OP::bsave = B::OP::bsave_fat;
	661	B::UNOP::bsave = B::UNOP::bsave_fat;
	662	B::BINOP::bsave = B::BINOP::bsave_fat;
	663	B::LISTOP::bsave = B::LISTOP::bsave_fat;
	664	}
	665	sub bwarn { print STDERR "Bytecode.pm: @_\n" }
	666
	667	for (@_) {
	668	if (/^-S/) {
	669	newasm = endasm = sub { };
	670	*asm = sub { print " @_\n" };
	671	*nice = sub ($) { print "\n@_\n" };
	672	} elsif (/^-H/) {
	673	require ByteLoader;
	674	$head = "#! $^X\nuse ByteLoader $ByteLoader::VERSION;\n";
	675	} elsif (/^-k/) {
	676	keep_syn;
	677	} elsif (/^-o(.*)$/) {
	678	my $ofile = $1;
	679	open STDOUT, ">$ofile" or die "open $ofile: $!";
	680	*B::COP::file = sub { $ofile } if $T_thatfile;
	681	} elsif (/^-f(.*)$/) {
	682	$files{$1} = 1;
	683	} elsif (/^-s/) {
	684	$scan = 1;
	685	} elsif (/^-b/) {
	686	$savebegins = 1;
	687	# these are here for the testsuite
	688	} elsif (/^-TD(.*)/) {
	689	$T_inhinc = 1;
	690	$cwd = $1;
	691	} elsif (/^-TF/) {
	692	$T_thatfile = 1;
a798dbf2	693	} else {
1df34986	694	bwarn "Ignoring '$_' option";
a798dbf2	695	}
1df34986	696	}
	697	if ($scan) {
	698	for(keys %files) {
	699	my $f;
	700	# KLUDGE
	701	open($f, $_) or open ($f, "$cwd/$_")
	702	or bwarn("cannot rescan '$_'"), next;
	703	while (<$f>) {
	704	/^#\sline\s+\d+\s+("?)(.)\1/ and $files{$2} = 1;
	705	/^#/ and next;
	706	if (/\bgoto\b/ && !$keep_syn) {
	707	bwarn "keeping the syntax tree: \"goto\" op found";
	708	keep_syn;
a798dbf2	709	}
a798dbf2	710	}
1df34986	711	close $f;
	712	}
	713	}
	714	binmode STDOUT;
	715	return sub {
	716	print $head if $head;
	717	newasm sub { print @_ };
	718
	719	defstash->bwalk;
	720	asm "main_start", main_start->opwalk;
	721	asm "main_root", main_root->ix;
	722	asm "main_cv", main_cv->ix;
	723	asm "curpad", (comppadlist->ARRAY)[1]->ix;
	724
	725	asm "signal", cstring "__WARN__" # XXX
	726	if warnhook->ix;
	727	asm "incav", inc_gv->AV->ix if $T_inhinc;
	728	save_cq;
	729	asm "incav", inc_gv->AV->ix if $T_inhinc;
	730	asm "dowarn", dowarn;
	731
	732	{
	733	no strict 'refs';
	734	nice "<DATA>";
	735	my $dh = *{defstash->NAME."::DATA"};
	736	local undef $/;
	737	if (length (my $data = <$dh>)) {
	738	asm "data", ord 'D';
	739	print $data;
a798dbf2	740	} else {
1df34986	741	asm "ret";
a798dbf2	742	}
a798dbf2	743	}
1df34986	744
1df34986	745	endasm;
a798dbf2	746	}
	747	}
	748
	749	1;