# B::Bytecode.pm
# Copyright (c) 1994-1999 Malcolm Beattie. All rights reserved.
# Copyright (c) 2003 Enache Adrian. All rights reserved.
# Copyright (c) 2008 Reini Urban <rurban@cpan.org>. 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;

our $VERSION = '1.02_03';

use strict;
use Config;
use 5.008;
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::Assembler qw(asm newasm endasm);
BEGIN {
  if ($] < 5.009) {
    B::Asmdata->import(qw(@specialsv_name));
  } else {
    B->import(qw(@specialsv_name));
  }
}
use B::Concise;

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

our ($quiet);
my ($varix, $opix, $savebegins, %walked, %files, @cloop, %debug);
my %strtab = (0,0);
my %svtab = (0,0);
my %optab = (0,0);
my %spectab = (0,0);
my $tix = 1;
my %ops = (0,0);
# sub asm ($;$$) { }
sub nice ($) { }
my $PERL510 = ($] >= 5.009005);
my $PERL511 = ($] >= 5.011);

BEGIN {
    my $ithreads = $Config{'useithreads'} eq 'define';
    eval qq{
	sub ITHREADS() { $ithreads }
	sub VERSION() { $] }
    }; die $@ if $@;
}

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

sub op_flags {
  return '' if $quiet;
  # B::Concise::op_flags($_[0]); # too terse
  # common flags (see BASOP.op_flags in op.h)
  my($x) = @_;
  my(@v);
  push @v, "WANT_VOID" if ($x & 3) == 1;
  push @v, "WANT_SCALAR" if ($x & 3) == 2;
  push @v, "WANT_LIST" if ($x & 3) == 3;
  push @v, "KIDS" if $x & 4;
  push @v, "PARENS" if $x & 8;
  push @v, "REF" if $x & 16;
  push @v, "MOD" if $x & 32;
  push @v, "STACKED" if $x & 64;
  push @v, "SPECIAL" if $x & 128;
  return join(",", @v);
}

sub sv_flags {
  return '' if $quiet or $B::Concise::VERSION < 0.74; # or ($] == 5.010);
  return '' unless $debug{Comment};
  return 'B::SPECIAL' if $_[0]->isa('B::SPECIAL');
  my ($sv) = @_;
  my %h;
  # TODO: Check with which Concise and B versions this works. 5.10.0 fails.
  # B::Concise 0.66 fails also
  sub B::Concise::fmt_line { return shift; }
  %h = B::Concise::concise_op($ops{$tix-1}) if ref $ops{$tix-1};
  B::Concise::concise_sv($_[0], \%h, 0);
}

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." $tix]";
	$ops{$tix} = $op;
	my $arg = $op->size | $op->type <<7;
	B::Assembler::maxopix($tix) if $debug{A};
	asm "newopx", $arg, sprintf("$arg=size:%d,type:%d",
				    $op->size, $op->type);
	$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 "ldspecsvx", $$spec, $specialsv_name[$$spec];
	$spectab{$$spec} = $varix = $tix++;
    }
}

sub B::SV::ix {
    my $sv = shift;
    my $ix = $svtab{$$sv};
    defined($ix) ? $ix : do {
	nice '['.class($sv).']';
	B::Assembler::maxsvix($tix) if $debug{A};
	asm "newsvx", $sv->FLAGS, $debug{Comment} ? sv_flags($sv) : '';
	$svtab{$$sv} = $varix = $ix = $tix++;
	#nice "\tsvtab ".$$sv." => bsave(".$ix.");
	$sv->bsave($ix);
	$ix;
    }
}

sub B::GV::ix {
    my ($gv,$desired) = @_;
    my $ix = $svtab{$$gv};
    defined($ix) ? $ix : do {
        if ($debug{G} and !$PERL510) {
	  eval "require B::Debug;";
	  $gv->B::GV::debug;
        }
	if (($PERL510 and $gv->isGV_with_GP) or
	    (!$PERL510 and $gv->GP))
	{ # only gv with gp
	    my ($svix, $avix, $hvix, $cvix, $ioix, $formix);
	    nice "[GV]";
	    # 510 without debugging misses B::SPECIAL::NAME
	    my $name;
	    if ($PERL510 and ($gv->STASH->isa('B::SPECIAL') or $gv->isa('B::SPECIAL'))) {
	      $name = '_';
	      return 0;
	    } else {
	      $name = $gv->STASH->NAME . "::"
		. (class($gv) eq 'B::SPECIAL' ? '_' : $gv->NAME);
	    }
	    asm "gv_fetchpvx", cstring $name;
	    $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;

	    # XXX {{{{
	    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, sv_flags($gv) unless $ix == $varix;
	    asm "gp_sv", $svix, sv_flags($gv->SV);
	    asm "gp_av", $avix, sv_flags($gv->AV);
	    asm "gp_hv", $hvix, sv_flags($gv->HV);
	    asm "gp_cv", $cvix, sv_flags($gv->CV);
	    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 "newsvx", $gv->FLAGS, $debug{Comment} ? sv_flags($gv) : '';
	    $svtab{$$gv} = $varix = $ix = $tix++;
	    $gv->B::PVMG::bsave($ix);
	    if (!$PERL510) {
	      #GV_without_GP has no flags?
	      asm "xgv_flags", $gv->GvFLAGS;
	    }
	    if (!$PERL510 and $gv->STASH) {
	      my $stashix = $gv->STASH->ix;
	      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_stashpvx", cstring $name;
	    asm "sv_flags", $hv->FLAGS;
	    $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 "newsvx", $hv->FLAGS, $debug{Comment} ? sv_flags($hv) : '';
	    $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;
	    if (VERSION < 5.009) {
		asm "xnv", $hv->NVX;
	    }
	    asm "xmg_stash", $stashix;
	    asm("xhv_riter", $hv->RITER) if VERSION < 5.009;
	}
	asm "sv_refcnt", $hv->REFCNT;
	$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, sv_flags($sv) unless $ix == $varix;
    asm "sv_refcnt", $sv->REFCNT;
}

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);
    if ($PERL510) { # was VERSION >= 5.009
	# See note below in B::PVNV::bsave
	return if $sv->isa('B::AV');
	return if $sv->isa('B::HV');
	return if $sv->isa('B::CV');
	return if $sv->isa('B::GV');}
    bwarn(sprintf("PVIV sv:%s flags:0x%x",class($sv),$sv->FLAGS)) if $debug{M};
    # PVIV GV 8009, GV flags & (4000|8000) illegal (SVp_SCREAM|SVp_POK)
    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);
    if ($PERL510) { # VERSION >= 5.009
	# Magical AVs end up here, but AVs now don't have an NV slot actually
	# allocated. Hence don't write out assembly to store the NV slot if
	# we're actually an array.
	return if $sv->isa('B::AV');
	# Likewise HVs have no NV slot actually allocated.
	# I don't think that they can get here, but better safe than sorry
	return if $sv->isa('B::HV');
	return if $sv->isa('B::CV');
	return if $sv->isa('B::FM');
	return if $sv->isa('B::GV');
	return if $sv->isa('B::IO');
    }
    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 unless $PERL510;
    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 $gvix = $cv->GV->ix;
    my $padlistix = $cv->PADLIST->ix;
    my $outsideix = $cv->OUTSIDE->ix;
    my $constix = $cv->CONST ? $cv->XSUBANY->ix : 0;
    my $startix = $cv->START->opwalk;
    my $rootix = $cv->ROOT->ix;

    $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; # hack. who in the world understands this? hands up!
    my $stashix = $av->SvSTASH->ix;

    nice "-AV-",
    asm "ldsv", $varix = $ix, sv_flags($av) unless $ix == $varix;
    asm "av_extend", $av->MAX if $av->MAX >= 0;
    # asm "av_pushx", $_->ix, sv_flags($_) for @array;
    asm "av_pushx", $_ for @array;
    asm "sv_refcnt", $av->REFCNT;
    if (!$PERL510) { # VERSION < 5.009
	asm "xav_flags", $av->AvFLAGS;
    }
    asm "xmg_stash", $stashix;
}

sub B::GV::desired {
    my $gv = shift;
    my ($cv, $form);
    if ($debug{G} and !$PERL510) {
      eval "require B::Debug;";
      $gv->debug;
    }
    $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 ($] > 5.006 and $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_fetchpvx", cstring $hv->NAME . "::$k";
	    $svtab{$$v} = $varix = $tix;
	    $v->bsave($tix++);
	    asm "sv_flags", $v->FLAGS;
	}
    }
}

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


sub B::OP::bsave_thin {
    my ($op, $ix) = @_;
    bwarn(B::peekop($op), ", ix: $ix") if $debug{o};
    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_next", $nextix;
    asm "op_targ", $op->targ if $op->type;	# tricky
    asm "op_flags", $op->flags, op_flags($op->flags);
    asm "op_private", $op->private; # private concise flags?
}

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 eq '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 {
    my ($op, $ix) = @_;
    if ($op->name eq 'aassign' && $op->private & B::OPpASSIGN_HASH()) {
	my $last = $op->last;
	my $lastix = do {
	    local *B::OP::bsave = *B::OP::bsave_fat;
	    local *B::UNOP::bsave = *B::UNOP::bsave_fat;
	    $last->ix;
	};
	asm "ldop", $lastix unless $lastix == $opix;
	asm "op_targ", $last->targ;
	$op->B::OP::bsave($ix);
	asm "op_last", $lastix;
    } else {
	$op->B::OP::bsave($ix);
    }
}

# not needed if no pseudohashes

*B::BINOP::bsave = *B::OP::bsave if $PERL510; #VERSION >= 5.009;

# deal with sort / formline

sub B::LISTOP::bsave {
    my ($op, $ix) = @_;
    bwarn($op->peekop, ", ix: $ix") if $debug{o};
    my $name = $op->name;
    sub blocksort() { OPf_SPECIAL|OPf_STACKED }
    if ($name eq 'sort' && ($op->flags & blocksort) == blocksort) {
	my $first = $op->first;
	my $pushmark = $first->sibling;
	my $rvgv = $pushmark->first;
	my $leave = $rvgv->first;

	my $leaveix = $leave->ix;

	my $rvgvix = $rvgv->ix;
	asm "ldop", $rvgvix unless $rvgvix == $opix;
	asm "op_first", $leaveix;

	my $pushmarkix = $pushmark->ix;
	asm "ldop", $pushmarkix unless $pushmarkix == $opix;
	asm "op_first", $rvgvix;

	my $firstix = $first->ix;
	asm "ldop", $firstix unless $firstix == $opix;
	asm "op_sibling", $pushmarkix;

	$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;
    bwarn(B::peekop($op), ", ix: $ix $last: $last, lastix: $lastix") if $debug{o};
    if (!$PERL510 && $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;
    bwarn(B::peekop($op), ", ix: $ix") if $debug{o};

    $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

    bwarn(B::peekop($op), ", ix: $ix") if $debug{M} or $debug{o};
    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;
	    # 5.9 $op->pmtargetoff?
	}
	$op->B::BINOP::bsave($ix);
	if ($op->pmstashpv) { # avoid empty stash? if (table) pre-compiled else re-compile
	  if (!$PERL510) {
	    asm "op_pmstashpv", pvix $op->pmstashpv;
	  } else {
	    # crash in 5.10, 5.11
	    bwarn("op_pmstashpv ignored") if $debug{M};
	  }
	} else {
	  bwarn("op_pmstashpv main") if $debug{M};
	  asm "op_pmstashpv", pvix "main" unless $PERL510;
	}
    } 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;

    if ( !$PERL510 ) {
      bwarn("PMOP op_pmflags: ",$op->pmflags) if $debug{M};
      asm "op_pmflags", $op->pmflags;
      asm "op_pmpermflags", $op->pmpermflags;
      asm "op_pmdynflags", $op->pmdynflags;
      # asm "op_pmnext", $pmnextix;	# XXX broken
      asm "newpv", pvstring $op->precomp; # Special sequence: This is the arg for the next pregcomp
      asm "pregcomp";
    } elsif ( $PERL510 ) {
      if (ITHREADS and $op->pmoffset) {
	asm "op_pmflags",  $op->pmflags | 2;
	bwarn("PMOP pmstashpv: ",$op->pmstashpv, ", pmflags: ",$op->pmflags | 2) if $debug{M};
      } else {
	asm "op_pmflags",  $op->pmflags;
	bwarn("PMOP pmstashpv: ",$op->pmstashpv, ", pmflags: ",$op->pmflags) if $debug{M};
      }
      asm "newpv", pvstring $op->precomp;
      asm "pregcomp";
      #asm "op_reflags",  $op->reflags; # pregcomp does not set the extflags, just the pmflags
      #asm "op_reflags",  $op->reflags; # overwrite the extflags from 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);
    # crashed in 5.11
    #if ($PERL511) {
    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;
    if (ITHREADS) {
	$cop->B::OP::bsave($ix);
	asm "cop_stashpv", pvix $cop->stashpv, $cop->stashpv;
	asm "cop_file", pvix $cop->file, $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, $cop->label if $cop->label;	# XXX AD
    asm "cop_seq", $cop->cop_seq;
    asm "cop_arybase", $cop->arybase unless $PERL510;
    asm "cop_line", $cop->line;
    asm "cop_warnings", $warnix;
    if (!$PERL510) {
      asm "cop_io", $cop->io->ix;
    }
}

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 { goto A while 1; A: }
		for (my $op = $_->START; $$op; $op = $op->next) {
		    next unless $op->name eq 'require' ||
			# this kludge needed for tests
			$op->name eq 'gv' && do {
			    my $gv = class($op) eq 'SVOP' ?
				$op->gv :
			    	(($_->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
			    $$gv && $gv->NAME =~ /use_ok|plan/
			};
		    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, $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" unless $quiet; }

    for (@_) {
	if (/^-q(q?)/) {
	  $quiet = 1;
	} elsif (/^-S/) {
	  $debug{Comment} = 1;
	  *newasm = *endasm = sub { };
	  *asm = sub($;$$) {
	    undef $_[2] if defined $_[2] and $quiet;
	    (defined $_[2])
	      ? print $_[0]," ",$_[1],"\t# ",$_[2],"\n"
	      : print "@_\n"
	   };
	  *nice = sub ($) { print "\n# @_\n" unless $quiet;};
	} elsif (/^-v/) {
	  warn "conflicting -q ignored" if $quiet;
	  *nice = sub ($) { print "\n# @_\n"; print STDERR "@_\n" };
	} elsif (/^-H/) {
	  require ByteLoader;
	  my $version = $ByteLoader::VERSION;
	  $head = "#! $^X
use ByteLoader '$ByteLoader::VERSION';
";
	  # Maybe: Fix the plc reader, if 'perl -MByteLoader <.plc>' is called
	} elsif (/^-k/) {
	  keep_syn;
	} elsif (/^-o(.*)$/) {
	  open STDOUT, ">$1" or die "open $1: $!";
	} elsif (/^-f(.*)$/) {
	  $files{$1} = 1;
	} elsif (/^-D(.*)$/) {
	  $debug{$1}++;
	} elsif (/^-s(.*)$/) {
	  $scan = length($1) ? $1 : $0;
	} elsif (/^-b/) {
	  $savebegins = 1;
	# this is here for the testsuite
	} elsif (/^-TI/) {
	  $T_inhinc = 1;
	} elsif (/^-TF(.*)/) {
	  my $thatfile = $1;
	  *B::COP::file = sub { $thatfile };
	} else {
	  bwarn "Ignoring '$_' option";
	}
    }
    if ($scan) {
	my $f;
	if (open $f, $scan) {
	    while (<$f>) {
		/^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1;
		/^#/ and next;
		if (/\bgoto\b\s*[^&]/ && !$keep_syn) {
		    bwarn "keeping the syntax tree: \"goto\" op found";
		    keep_syn;
		}
	    }
	} else {
	    bwarn "cannot rescan '$scan'";
	}
	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"};
	    unless (eof $dh) {
		local undef $/;
		asm "data", ord 'D';
		print <$dh>;
	    } else {
		asm "ret";
	    }
	}

	endasm;
    }
}

1;

=head1 NAME

B::Bytecode - Perl compiler's bytecode backend

=head1 SYNOPSIS

B<perl -MO=Bytecode>[B<,-H>][B<,-o>I<script.plc>] I<script.pl>

=head1 DESCRIPTION

Compiles a Perl script into a bytecode format that could be loaded
later by the ByteLoader module and executed as a regular Perl script.

=head1 EXAMPLE

    $ perl -MO=Bytecode,-H,-ohi -e 'print "hi!\n"'
    $ perl hi
    hi!

=head1 OPTIONS

=over 4

=item B<-H>

Prepend a C<use ByteLoader VERSION;> line to the produced bytecode.

=item B<-b>

Save all the BEGIN blocks. Normally only BEGIN blocks that C<require>
other files (ex. C<use Foo;>) are saved.

=item B<-k>

Keep the syntax tree - it is stripped by default.

=item B<-o>I<outfile>

Put the bytecode in <outfile> instead of dumping it to STDOUT.

=item B<-s>

Scan the script for C<# line ..> directives and for <goto LABEL>
expressions. When gotos are found keep the syntax tree.

=item B<-S>

Output assembler source rather than piping it through the assembler
and outputting bytecode.
Without -q the assembler source is commented.

=item B<-q>

Be quiet.

=item B<-v>

Be verbose.

=item B<-Do>

OPs, prints each OP as it's processed

=item B<-D>I<M>

Set debugging flag for more verbose STDERR output.
Verbose debugging options are crucial, because we have no interactive
debugger at the early CHECK step, where the compilation happens.

B<M> for Magic and Matches.

=item B<-D>I<G>

Debug GV's

=item B<-D>I<A>

Set developer B<A>ssertions, to help find possible obj-indices out of range.

=back

=head1 KNOWN BUGS

=over 4

=item *

C<BEGIN { goto A: while 1; A: }> won't even compile.

=item *

C<?...?> and C<reset> do not work as expected.

=item *

variables in C<(?{ ... })> constructs are not properly scoped.

=item *

Scripts that use source filters will fail miserably.

=item *

Special GV's fail.

=back

=head1 NOTICE

There are also undocumented bugs and options.

THIS CODE IS HIGHLY EXPERIMENTAL. USE AT YOUR OWN RISK.

=head1 AUTHORS

Originally written by Malcolm Beattie <mbeattie@sable.ox.ac.uk> and
modified by Benjamin Stuhl <sho_pi@hotmail.com>.

Rewritten by Enache Adrian <enache@rdslink.ro>, 2003 a.d.

Enhanced by Reini Urban <rurban@cpan.org>, 2008

=cut
