X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FB%2FB%2FBytecode.pm;h=164c10f0f96362201ba03072592a5c1e0471bc5d;hb=1df3498620ecc1df99a2455e631a135f1710416f;hp=4b2197ef4301b12fd23edc9954b289323943d2f4;hpb=e717db08e9ac58aa42b4beba29a3a135ffd370d0;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/ext/B/B/Bytecode.pm b/ext/B/B/Bytecode.pm
index 4b2197e..164c10f 100644
--- a/ext/B/B/Bytecode.pm
+++ b/ext/B/B/Bytecode.pm
@@ -1,983 +1,749 @@
-#      Bytecode.pm
-#
-#      Copyright (c) 1996-1998 Malcolm Beattie
-#
-#      You may distribute under the terms of either the GNU General Public
-#      License or the Artistic License, as specified in the README file.
-#
+# 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 IO::File;
-
-use B qw(main_cv main_root main_start comppadlist
-	 class peekop walkoptree svref_2object cstring walksymtable
-	 init_av begin_av end_av
-	 SVf_POK SVp_POK SVf_IOK SVp_IOK SVf_NOK SVp_NOK
-	 SVf_READONLY GVf_IMPORTED_AV GVf_IMPORTED_CV GVf_IMPORTED_HV
-	 GVf_IMPORTED_SV
-	);
-use B::Asmdata qw(@optype @specialsv_name);
-use B::Assembler qw(assemble_fh);
-
-my %optype_enum;
-my $i;
-for ($i = 0; $i < @optype; $i++) {
-    $optype_enum{$optype[$i]} = $i;
-}
-
-# Following is SVf_POK|SVp_POK
-# XXX Shouldn't be hardwired
-sub POK () { SVf_POK|SVp_POK }
-
-# Following is SVf_IOK|SVp_IOK
-# XXX Shouldn't be hardwired
-sub IOK () { SVf_IOK|SVp_IOK }
-
-# Following is SVf_NOK|SVp_NOK
-# XXX Shouldn't be hardwired
-sub NOK () { SVf_NOK|SVp_NOK }
-# nonexistant flags (see B::GV::bytecode for usage)
-sub GVf_IMPORTED_IO () { 0; }
-sub GVf_IMPORTED_FORM () { 0; }
-my ($verbose, $module_only, $no_assemble, $debug_bc, $debug_cv);
-my $assembler_pid;
-
-my @packages;	# list of packages to compile
-# Optimisation options. On the command line, use hyphens instead of
-# underscores for compatibility with gcc-style options. We use
-# underscores here because they are OK in (strict) barewords.
-my ($strip_syntree, $compress_nullops, $omit_seq, $bypass_nullops);
-my %optimise = (strip_syntax_tree	=> \$strip_syntree,
-		compress_nullops	=> \$compress_nullops,
-		omit_sequence_numbers	=> \$omit_seq,
-		bypass_nullops		=> \$bypass_nullops);
-
-my $nextix = 0;
-my %symtable;	# maps object addresses to object indices.
-		# Filled in at allocation (newsv/newop) time.
-my %saved;	# maps object addresses (for SVish classes) to "saved yet?"
-		# flag. Set at FOO::bytecode time usually by SV::bytecode.
-		# Manipulated via saved(), mark_saved(), unmark_saved().
-
-my $svix = -1;	# we keep track of when the sv register contains an element
-		# of the object table to avoid unnecessary repeated
-		# consecutive ldsv instructions.
-my $opix = -1;	# Ditto for the op register.
-
-sub ldsv {
-    my $ix = shift;
-    if ($ix != $svix) {
-	print "ldsv $ix\n";
-	$svix = $ix;
-    }
-}
+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 stsv {
-    my $ix = shift;
-    print "stsv $ix\n";
-    $svix = $ix;
+sub pvstring {
+    my $pv = shift;
+    defined($pv) ? cstring ($pv."\0") : "\"\"";
 }
 
-sub set_svix {
-    $svix = shift;
+sub pvix {
+    my $str = pvstring shift;
+    my $ix = $strtab{$str};
+    defined($ix) ? $ix : do {
+	asm "newpv", $str;
+	asm "stpv", $strtab{$str} = $tix;
+	$tix++;
+    }
 }
 
-sub ldop {
-    my $ix = shift;
-    if ($ix != $opix) {
-	print "ldop $ix\n";
-	$opix = $ix;
+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 stop {
-    my $ix = shift;
-    print "stop $ix\n";
-    $opix = $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 set_opix {
-    $opix = shift;
+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 pvstring {
-    my $str = shift;
-    if (defined($str)) {
-	return cstring($str . "\0");
-    } else {
-	return '""';
+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 nv {
-    # print full precision
-    my $str = sprintf "%.40f", $_[0];
-    return $str;
+sub B::NULL::ix {
+    my $sv = shift;
+    $$sv ? $sv->B::SV::ix : 0;
 }
-sub saved { $saved{${$_[0]}} }
-sub mark_saved { $saved{${$_[0]}} = 1 }
-sub unmark_saved { $saved{${$_[0]}} = 0 }
 
-sub debug { $debug_bc = shift }
+sub B::NULL::opwalk { 0 }
 
-sub B::OBJECT::nyi {
-    my $obj = shift;
-    warn sprintf("bytecode save method for %s (0x%x) not yet implemented\n",
-		 class($obj), $$obj);
-}
+#################################################
 
-#
-# objix may stomp on the op register (for op objects)
-# or the sv register (for SV objects)
-#
-sub B::OBJECT::objix {
-    my $obj = shift;
-    my $ix = $symtable{$$obj};
-    if (defined($ix)) {
-	return $ix;
-    } else {
-	$obj->newix($nextix);
-	return $symtable{$$obj} = $nextix++;
-    }
-}
+sub B::NULL::bsave {
+    my ($sv,$ix) = @_;
 
-sub B::SV::newix {
-    my ($sv, $ix) = @_;
-    printf "newsv %d\t# %s\n", $sv->FLAGS & 0xf, class($sv);
-    stsv($ix);    
+    nice '-'.class($sv).'-',
+    asm "ldsv", $varix = $ix unless $ix == $varix;
+    asm "sv_refcnt", $sv->REFCNT;
+    asm "sv_flags", $sv->FLAGS;
 }
 
-sub B::GV::newix {
-    my ($gv, $ix) = @_;
-    my $gvname = $gv->NAME;
-    my $name = cstring($gv->STASH->NAME . "::" . $gvname);
-    print "gv_fetchpv $name\n";
-    stsv($ix);
-}
+sub B::SV::bsave;
+    *B::SV::bsave = *B::NULL::bsave;
 
-sub B::HV::newix {
-    my ($hv, $ix) = @_;
-    my $name = $hv->NAME;
-    if ($name) {
-	# It's a stash
-	printf "gv_stashpv %s\n", cstring($name);
-	stsv($ix);
-    } else {
-	# It's an ordinary HV. Fall back to ordinary newix method
-	$hv->B::SV::newix($ix);
-    }
+sub B::RV::bsave {
+    my ($sv,$ix) = @_;
+    my $rvix = $sv->RV->ix;
+    $sv->B::NULL::bsave($ix);
+    asm "xrv", $rvix;
 }
 
-sub B::SPECIAL::newix {
-    my ($sv, $ix) = @_;
-    # Special case. $$sv is not the address of the SV but an
-    # index into svspecialsv_list.
-    printf "ldspecsv $$sv\t# %s\n", $specialsv_name[$$sv];
-    stsv($ix);
+sub B::PV::bsave {
+    my ($sv,$ix) = @_;
+    $sv->B::NULL::bsave($ix);
+    asm "newpv", pvstring $sv->PVBM;
+    asm "xpv";
 }
 
-sub B::OP::newix {
-    my ($op, $ix) = @_;
-    my $class = class($op);
-    my $typenum = $optype_enum{$class};
-    require('Carp.pm'), Carp::croak("OP::newix: can't understand class $class")
-	 unless defined($typenum);
-    print "newop $typenum\t# $class\n";
-    stop($ix);
+sub B::IV::bsave {
+    my ($sv,$ix) = @_;
+    $sv->B::NULL::bsave($ix);
+    asm "xiv", $sv->IVX;
 }
 
-sub B::OP::walkoptree_debug {
-    my $op = shift;
-    warn(sprintf("walkoptree: %s\n", peekop($op)));
+sub B::NV::bsave {
+    my ($sv,$ix) = @_;
+    $sv->B::NULL::bsave($ix);
+    asm "xnv", sprintf "%.40g", $sv->NVX;
 }
 
-sub B::OP::bytecode {
-    my $op = shift;
-    my $next = $op->next;
-    my $nextix;
-    my $sibix = $op->sibling->objix unless $strip_syntree;
-    my $ix = $op->objix;
-    my $type = $op->type;
-
-    if ($bypass_nullops) {
-	$next = $next->next while $$next && $next->type == 0;
-    }
-    $nextix = $next->objix;
-
-    printf "# %s\n", peekop($op) if $debug_bc;
-    ldop($ix);
-    print "op_next $nextix\n";
-    print "op_sibling $sibix\n" unless $strip_syntree;
-    printf "op_type %s\t# %d\n", "pp_" . $op->name, $type;
-    printf("op_seq %d\n", $op->seq) unless $omit_seq;
-    if ($type || !$compress_nullops) {
-	printf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n",
-	    $op->targ, $op->flags, $op->private;
-    }
+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::UNOP::bytecode {
-    my $op = shift;
-    my $firstix = $op->first->objix unless $strip_syntree;
-    $op->B::OP::bytecode;
-    if (($op->type || !$compress_nullops) && !$strip_syntree) {
-	print "op_first $firstix\n";
-    }
+sub B::PVNV::bsave {
+    my ($sv,$ix) = @_;
+    $sv->B::PVIV::bsave($ix);
+    asm "xnv", sprintf "%.40g", $sv->NVX;
 }
 
-sub B::LOGOP::bytecode {
-    my $op = shift;
-    my $otherix = $op->other->objix;
-    $op->B::UNOP::bytecode;
-    print "op_other $otherix\n";
-}
+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;
+    }
 
-sub B::SVOP::bytecode {
-    my $op = shift;
-    my $sv = $op->sv;
-    my $svix = $sv->objix;
-    $op->B::OP::bytecode;
-    print "op_sv $svix\n";
-    $sv->bytecode;
+    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::PADOP::bytecode {
-    my $op = shift;
-    my $padix = $op->padix;
-    $op->B::OP::bytecode;
-    print "op_padix $padix\n";
+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::PVOP::bytecode {
-    my $op = shift;
-    my $pv = $op->pv;
-    $op->B::OP::bytecode;
-    #
-    # This would be easy except that OP_TRANS uses a PVOP to store an
-    # endian-dependent array of 256 shorts instead of a plain string.
-    #
-    if ($op->name eq "trans") {
-	my @shorts = unpack("s256", $pv); # assembler handles endianness
-	print "op_pv_tr ", join(",", @shorts), "\n";
-    } else {
-	printf "newpv %s\nop_pv\n", pvstring($pv);
+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::BINOP::bytecode {
-    my $op = shift;
-    my $lastix = $op->last->objix unless $strip_syntree;
-    $op->B::UNOP::bytecode;
-    if (($op->type || !$compress_nullops) && !$strip_syntree) {
-	print "op_last $lastix\n";
-    }
-}
+######################################################
 
-sub B::LISTOP::bytecode {
-    my $op = shift;
-    my $children = $op->children unless $strip_syntree;
-    $op->B::BINOP::bytecode;
-    if (($op->type || !$compress_nullops) && !$strip_syntree) {
-	print "op_children $children\n";
+
+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::LOOP::bytecode {
-    my $op = shift;
-    my $redoopix = $op->redoop->objix;
-    my $nextopix = $op->nextop->objix;
-    my $lastopix = $op->lastop->objix;
-    $op->B::LISTOP::bytecode;
-    print "op_redoop $redoopix\nop_nextop $nextopix\nop_lastop $lastopix\n";
-}
+sub B::OP::bsave;
+    *B::OP::bsave = *B::OP::bsave_thin;
 
-sub B::COP::bytecode {
-    my $op = shift;
-    my $file = $op->file;
-    my $line = $op->line;
-    if ($debug_bc) { # do this early to aid debugging
-	printf "# line %s:%d\n", $file, $line;
-    }
-    my $stashpv = $op->stashpv;
-    my $warnings = $op->warnings;
-    my $warningsix = $warnings->objix;
-    $warnings->bytecode;
-    $op->B::OP::bytecode;
-    printf <<"EOT", pvstring($op->label), pvstring($stashpv), $op->cop_seq, pvstring($file), $op->arybase;
-newpv %s
-cop_label
-newpv %s
-cop_stashpv
-cop_seq %d
-newpv %s
-cop_file
-cop_arybase %d
-cop_line $line
-cop_warnings $warningsix
-EOT
-}
-
-sub B::PMOP::bytecode {
-    my $op = shift;
-    my $replroot = $op->pmreplroot;
-    my $replrootix = $replroot->objix;
-    my $replstartix = $op->pmreplstart->objix;
-    my $opname = $op->name;
-    # pmnext is corrupt in some PMOPs (see misc.t for example)
-    #my $pmnextix = $op->pmnext->objix;
-
-    if ($$replroot) {
-	# OP_PUSHRE (a mutated version of OP_MATCH for the regexp
-	# argument to a split) stores a GV in op_pmreplroot instead
-	# of a substitution syntax tree. We don't want to walk that...
-	if ($opname eq "pushre") {
-	    $replroot->bytecode;
-	} else {
-	    walkoptree($replroot, "bytecode");
-	}
-    }
-    $op->B::LISTOP::bytecode;
-    if ($opname eq "pushre") {
-	printf "op_pmreplrootgv $replrootix\n";
+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 {
-	print "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n";
+	$op->B::OP::bsave($ix);
     }
-    my $re = pvstring($op->precomp);
-    # op_pmnext omitted since a perl bug means it's sometime corrupt
-    printf <<"EOT", $op->pmflags, $op->pmpermflags;
-op_pmflags 0x%x
-op_pmpermflags 0x%x
-newpv $re
-pregcomp
-EOT
 }
 
-sub B::SV::bytecode {
-    my $sv = shift;
-    return if saved($sv);
-    my $ix = $sv->objix;
-    my $refcnt = $sv->REFCNT;
-    my $flags = sprintf("0x%x", $sv->FLAGS);
-    ldsv($ix);
-    print "sv_refcnt $refcnt\nsv_flags $flags\n";
-    mark_saved($sv);
-}
+# fat versions
 
-sub B::PV::bytecode {
-    my $sv = shift;
-    return if saved($sv);
-    $sv->B::SV::bytecode;
-    printf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK;
-}
+sub B::OP::bsave_fat {
+    my ($op, $ix) = @_;
+    my $siblix = $op->sibling->ix;
 
-sub B::IV::bytecode {
-    my $sv = shift;
-    return if saved($sv);
-    my $iv = $sv->IVX;
-    $sv->B::SV::bytecode;
-    printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32" if $sv->FLAGS & IOK; # could be PVNV
+    $op->B::OP::bsave_thin($ix);
+    asm "op_sibling", $siblix;
+    # asm "op_seq", -1;			XXX don't allocate OPs piece by piece
 }
 
-sub B::NV::bytecode {
-    my $sv = shift;
-    return if saved($sv);
-    $sv->B::SV::bytecode;
-    printf "xnv %s\n", nv($sv->NVX);
+sub B::UNOP::bsave_fat {
+    my ($op,$ix) = @_;
+    my $firstix = $op->first->ix;
+
+    $op->B::OP::bsave($ix);
+    asm "op_first", $firstix;
 }
 
-sub B::RV::bytecode {
-    my $sv = shift;
-    return if saved($sv);
-    my $rv = $sv->RV;
-    my $rvix = $rv->objix;
-    $rv->bytecode;
-    $sv->B::SV::bytecode;
-    print "xrv $rvix\n";
+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::PVIV::bytecode {
-    my $sv = shift;
-    return if saved($sv);
-    my $iv = $sv->IVX;
-    $sv->B::PV::bytecode;
-    printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32";
+sub B::LOGOP::bsave {
+    my ($op,$ix) = @_;
+    my $otherix = $op->other->ix;
+
+    $op->B::UNOP::bsave($ix);
+    asm "op_other", $otherix;
 }
 
-sub B::PVNV::bytecode {
-    my $sv = shift;
-    my $flag = shift || 0;
-    # The $flag argument is passed through PVMG::bytecode by BM::bytecode
-    # and AV::bytecode and indicates special handling. $flag = 1 is used by
-    # BM::bytecode and means that we should ensure we save the whole B-M
-    # table. It consists of 257 bytes (256 char array plus a final \0)
-    # which follow the ordinary PV+\0 and the 257 bytes are *not* reflected
-    # in SvCUR. $flag = 2 is used by AV::bytecode and means that we only
-    # call SV::bytecode instead of saving PV and calling NV::bytecode since
-    # PV/NV/IV stuff is different for AVs.
-    return if saved($sv);
-    if ($flag == 2) {
-	$sv->B::SV::bytecode;
-    } else {
-	my $pv = $sv->PV;
-	$sv->B::IV::bytecode;
-	printf "xnv %s\n", nv($sv->NVX);
-	if ($flag == 1) {
-	    $pv .= "\0" . $sv->TABLE;
-	    printf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257;
-	} else {
-	    printf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK;
+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;
     }
-}
 
-sub B::PVMG::bytecode {
-    my ($sv, $flag) = @_;
-    # See B::PVNV::bytecode for an explanation of $flag.
-    return if saved($sv);
-    # XXX We assume SvSTASH is already saved and don't save it later ourselves
-    my $stashix = $sv->SvSTASH->objix;
-    my @mgchain = $sv->MAGIC;
-    my (@mgobjix, $mg);
-    #
-    # We need to traverse the magic chain and get objix for each OBJ
-    # field *before* we do B::PVNV::bytecode since objix overwrites
-    # the sv register. However, we need to write the magic-saving
-    # bytecode *after* B::PVNV::bytecode since sv isn't initialised
-    # to refer to $sv until then.
-    #
-    @mgobjix = map($_->OBJ->objix, @mgchain);
-    $sv->B::PVNV::bytecode($flag);
-    print "xmg_stash $stashix\n";
-    foreach $mg (@mgchain) {
-	printf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n",
-	    cstring($mg->TYPE), shift(@mgobjix), pvstring($mg->PTR);
-    }
-}
+    asm $rrop, $rrarg if $rrop;
+    asm "op_pmreplstart", $rstart if $rstart;
 
-sub B::PVLV::bytecode {
-    my $sv = shift;
-    return if saved($sv);
-    $sv->B::PVMG::bytecode;
-    printf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE);
-xlv_targoff %d
-xlv_targlen %d
-xlv_type %s
-EOT
+    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::BM::bytecode {
-    my $sv = shift;
-    return if saved($sv);
-    # See PVNV::bytecode for an explanation of what the argument does
-    $sv->B::PVMG::bytecode(1);
-    printf "xbm_useful %d\nxbm_previous %d\nxbm_rare %d\n",
-	$sv->USEFUL, $sv->PREVIOUS, $sv->RARE;
-}
+sub B::SVOP::bsave {
+    my ($op,$ix) = @_;
+    my $svix = $op->sv->ix;
 
-sub B::GV::bytecode {
-    my $gv = shift;
-    return if saved($gv);
-    return unless grep { $_ eq $gv->STASH->NAME; } @packages;
-    my $ix = $gv->objix;
-    mark_saved($gv);
-    ldsv($ix);
-    printf <<"EOT", $gv->FLAGS, $gv->GvFLAGS;
-sv_flags 0x%x
-xgv_flags 0x%x
-EOT
-    my $refcnt = $gv->REFCNT;
-    printf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1;
-    return if $gv->is_empty;
-    printf <<"EOT", $gv->LINE, pvstring($gv->FILE);
-gp_line %d
-newpv %s
-gp_file
-EOT
-    my $gvname = $gv->NAME;
-    my $name = cstring($gv->STASH->NAME . "::" . $gvname);
-    my $egv = $gv->EGV;
-    my $egvix = $egv->objix;
-    my $gvrefcnt = $gv->GvREFCNT;
-    printf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1;
-    if ($gvrefcnt > 1 &&  $ix != $egvix) {
-	print "gp_share $egvix\n";
-    } else {
-	if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
-	    my $i;
-	    my @subfield_names = qw(SV AV HV CV FORM IO);
-	    @subfield_names = grep {;
-					no strict 'refs';
-					!($gv->GvFLAGS & ${\"GVf_IMPORTED_$_"}->());
-				} @subfield_names;
-	    my @subfields = map($gv->$_(), @subfield_names);
-	    my @ixes = map($_->objix, @subfields);
-	    # Reset sv register for $gv
-	    ldsv($ix);
-	    for ($i = 0; $i < @ixes; $i++) {
-		printf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
-	    }
-	    # Now save all the subfields
-	    my $sv;
-	    foreach $sv (@subfields) {
-		$sv->bytecode;
-	    }
-	}
-    }
+    $op->B::OP::bsave($ix);
+    asm "op_sv", $svix;
 }
 
-sub B::HV::bytecode {
-    my $hv = shift;
-    return if saved($hv);
-    mark_saved($hv);
-    my $name = $hv->NAME;
-    my $ix = $hv->objix;
-    if (!$name) {
-	# It's an ordinary HV. Stashes have NAME set and need no further
-	# saving beyond the gv_stashpv that $hv->objix already ensures.
-	my @contents = $hv->ARRAY;
-	my ($i, @ixes);
-	for ($i = 1; $i < @contents; $i += 2) {
-	    push(@ixes, $contents[$i]->objix);
-	}
-	for ($i = 1; $i < @contents; $i += 2) {
-	    $contents[$i]->bytecode;
-	}
-	ldsv($ix);
-	for ($i = 0; $i < @contents; $i += 2) {
-	    printf("newpv %s\nhv_store %d\n",
-		   pvstring($contents[$i]), $ixes[$i / 2]);
-	}
-	printf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS;
-    }
+sub B::PADOP::bsave {
+    my ($op,$ix) = @_;
+
+    $op->B::OP::bsave($ix);
+    asm "op_padix", $op->padix;
 }
 
-sub B::AV::bytecode {
-    my $av = shift;
-    return if saved($av);
-    my $ix = $av->objix;
-    my $fill = $av->FILL;
-    my $max = $av->MAX;
-    my (@array, @ixes);
-    if ($fill > -1) {
-	@array = $av->ARRAY;
-	@ixes = map($_->objix, @array);
-	my $sv;
-	foreach $sv (@array) {
-	    $sv->bytecode;
-	}
-    }
-    # See PVNV::bytecode for the meaning of the flag argument of 2.
-    $av->B::PVMG::bytecode(2);
-    # Recover sv register and set AvMAX and AvFILL to -1 (since we
-    # create an AV with NEWSV and SvUPGRADE rather than doing newAV
-    # which is what sets AvMAX and AvFILL.
-    ldsv($ix);
-    printf "sv_flags 0x%x\n", $av->FLAGS & ~SVf_READONLY; # SvREADONLY_off($av) in case PADCONST
-    printf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS;
-    if ($fill > -1) {
-	my $elix;
-	foreach $elix (@ixes) {
-	    print "av_push $elix\n";
-	}
+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 {
-	if ($max > -1) {
-	    print "av_extend $max\n";
-	}
-    }
-    printf "sv_flags 0x%x\n", $av->FLAGS; # restore flags from above
-}
-
-sub B::CV::bytecode {
-    my $cv = shift;
-    return if saved($cv);
-    return if ${$cv->GV} && ($cv->GV->GvFLAGS & GVf_IMPORTED_CV);
-    my $ix = $cv->objix;
-    $cv->B::PVMG::bytecode;
-    my $i;
-    my @subfield_names = qw(ROOT START STASH GV PADLIST OUTSIDE);
-    my @subfields = map($cv->$_(), @subfield_names);
-    my @ixes = map($_->objix, @subfields);
-    # Save OP tree from CvROOT (first element of @subfields)
-    my $root = shift @subfields;
-    if ($$root) {
-	walkoptree($root, "bytecode");
-    }
-    # Reset sv register for $cv (since above ->objix calls stomped on it)
-    ldsv($ix);
-    for ($i = 0; $i < @ixes; $i++) {
-	printf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
-    }
-    printf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->CvFLAGS;
-    printf "newpv %s\nxcv_file\n", pvstring($cv->FILE);
-    # Now save all the subfields (except for CvROOT which was handled
-    # above) and CvSTART (now the initial element of @subfields).
-    shift @subfields; # bye-bye CvSTART
-    my $sv;
-    foreach $sv (@subfields) {
-	$sv->bytecode;
+        asm "newpv", pvstring $pv;
+        asm "op_pv";
     }
 }
 
-sub B::IO::bytecode {
-    my $io = shift;
-    return if saved($io);
-    my $ix = $io->objix;
-    my $top_gv = $io->TOP_GV;
-    my $top_gvix = $top_gv->objix;
-    my $fmt_gv = $io->FMT_GV;
-    my $fmt_gvix = $fmt_gv->objix;
-    my $bottom_gv = $io->BOTTOM_GV;
-    my $bottom_gvix = $bottom_gv->objix;
-
-    $io->B::PVMG::bytecode;
-    ldsv($ix);
-    print "xio_top_gv $top_gvix\n";
-    print "xio_fmt_gv $fmt_gvix\n";
-    print "xio_bottom_gv $bottom_gvix\n";
-    my $field;
-    foreach $field (qw(TOP_NAME FMT_NAME BOTTOM_NAME)) {
-	printf "newpv %s\nxio_%s\n", pvstring($io->$field()), lc($field);
-    }
-    foreach $field (qw(LINES PAGE PAGE_LEN LINES_LEFT SUBPROCESS)) {
-	printf "xio_%s %d\n", lc($field), $io->$field();
-    }
-    printf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS;
-    $top_gv->bytecode;
-    $fmt_gv->bytecode;
-    $bottom_gv->bytecode;
-}
+sub B::LOOP::bsave {
+    my ($op,$ix) = @_;
+    my $nextix = $op->nextop->ix;
+    my $lastix = $op->lastop->ix;
+    my $redoix = $op->redoop->ix;
 
-sub B::SPECIAL::bytecode {
-    # nothing extra needs doing
+    $op->B::BINOP::bsave($ix);
+    asm "op_redoop", $redoix;
+    asm "op_nextop", $nextix;
+    asm "op_lastop", $lastix;
 }
 
-sub bytecompile_object {
-    for my $sv (@_) {
-	svref_2object($sv)->bytecode;
+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::GV::bytecodecv {
-    my $gv = shift;
-    my $cv = $gv->CV;
-    if ($$cv && !saved($cv)) {
-	if ($debug_cv) {
-	    warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
-			 $gv->STASH->NAME, $gv->NAME, $$cv, $$gv);
+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}};
 	}
-	$gv->bytecode;
+	$ix;
     }
 }
 
-sub save_call_queues {
-    if (ref(begin_av()) eq "B::AV") {	# this is just to save 'use Foo;' calls
-	for my $cv (begin_av->ARRAY) {
-	    my $name = $cv->STASH->NAME;
-	    next unless grep { $_ eq $name } @packages;
-	    my $op = $cv->START;
-	    $op = $op->next while ($$op && ref $op ne "B::UNOP");
-	    if ($$op && $op->name eq 'require') { # should be first UNOP
-		$cv->bytecode;
-		printf "push_begin %d\n", $cv->objix;
+#################################################
+
+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 (ref(init_av()) eq "B::AV") {
-	for my $cv (init_av->ARRAY) {
-	    next unless grep { $_ eq $cv->STASH->NAME } @packages;
-	    $cv->bytecode;
-	    printf "push_init %d\n", $cv->objix;
+    if (($av=init_av)->isa("B::AV")) {
+	for ($av->ARRAY) {
+	    next unless $_->FILE eq $0;
+	    asm "push_init", $_->ix;
 	}
     }
-    if (ref(end_av()) eq "B::AV") {
-	for my $cv (end_av->ARRAY) {
-	    next unless grep { $_ eq $cv->STASH->NAME } @packages;
-	    $cv->bytecode;
-	    printf "push_end %d\n", $cv->objix;
+    if (($av=end_av)->isa("B::AV")) {
+	for ($av->ARRAY) {
+	    next unless $_->FILE eq $0;
+	    asm "push_end", $_->ix;
 	}
     }
 }
 
-sub symwalk {
-     no strict 'refs';
-     my $ok = 1 if grep { (my $name = $_[0]) =~ s/::$//; $_ eq $name;} @packages;
-    if (grep { /^$_[0]/; } @packages) {
-	walksymtable(\%{"$_[0]"}, "bytecodecv", \&symwalk, $_[0]);
-    }
-    warn "considering $_[0] ... " . ($ok ? "accepted\n" : "rejected\n")
-	if $debug_bc;
-    $ok;
-}
-
-sub bytecompile_main {
-    my $curpad = (comppadlist->ARRAY)[1];
-    my $curpadix = $curpad->objix;
-    $curpad->bytecode;
-    walkoptree(main_root, "bytecode") unless ref(main_root) eq "B::NULL";
-    warn "done main program, now walking symbol table\n" if $debug_bc;
-    if (@packages) {
-	no strict qw(refs);
-	our %packages;
-	walksymtable(\%{"main::"}, "bytecodecv", \&symwalk);
-    } else {
-	die "No packages requested for compilation!\n";
-    }
-    save_call_queues;
-    printf "main_root %d\n", main_root->objix;
-    printf "main_start %d\n", main_start->objix;
-    printf "curpad $curpadix\n";
-    # XXX Do min_intro_pending and max_intro_pending matter?
-}
-
-sub prepare_assemble {
-    my $newfh = IO::File->new_tmpfile;
-    select($newfh);
-    binmode $newfh;
-    return $newfh;
-}
-
-sub do_assemble {
-    my $fh = shift;
-    seek($fh, 0, 0); # rewind the temporary file
-    assemble_fh($fh, sub { print OUT @_ });
-}
-
 sub compile {
-    my @options = @_;
-    my ($option, $opt, $arg);
-    open(OUT, ">&STDOUT");
-    binmode OUT;
-    select(OUT);
-  OPTION:
-    while ($option = shift @options) {
-	if ($option =~ /^-(.)(.*)/) {
-	    $opt = $1;
-	    $arg = $2;
+    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 {
-	    unshift @options, $option;
-	    last OPTION;
+	    bwarn "Ignoring '$_' option";
 	}
-	if ($opt eq "-" && $arg eq "-") {
-	    shift @options;
-	    last OPTION;
-	} elsif ($opt eq "o") {
-	    $arg ||= shift @options;
-	    open(OUT, ">$arg") or return "$arg: $!\n";
-	    binmode OUT;
-	} elsif ($opt eq "a") {
-	    $arg ||= shift @options;
-	    open(OUT, ">>$arg") or return "$arg: $!\n";
-	    binmode OUT;
-	} elsif ($opt eq "D") {
-	    $arg ||= shift @options;
-	    foreach $arg (split(//, $arg)) {
-		if ($arg eq "b") {
-		    $| = 1;
-		    debug(1);
-		} elsif ($arg eq "o") {
-		    B->debug(1);
-		} elsif ($arg eq "a") {
-		    B::Assembler::debug(1);
-		} elsif ($arg eq "C") {
-		    $debug_cv = 1;
+    }
+    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;
 		}
 	    }
-	} elsif ($opt eq "v") {
-	    $verbose = 1;
-	} elsif ($opt eq "m") { # XXX: NOP
-	    $module_only = 1;
-	} elsif ($opt eq "S") {
-	    $no_assemble = 1;
-	} elsif ($opt eq "f") {
-	    $arg ||= shift @options;
-	    my $value = $arg !~ s/^no-//;
-	    $arg =~ s/-/_/g;
-	    my $ref = $optimise{$arg};
-	    if (defined($ref)) {
-		$$ref = $value;
-	    } else {
-		warn qq(ignoring unknown optimisation option "$arg"\n);
-	    }
-	} elsif ($opt eq "O") {
-	    $arg = 1 if $arg eq "";
-	    my $ref;
-	    foreach $ref (values %optimise) {
-		$$ref = 0;
-	    }
-	    if ($arg >= 6) {
-		$strip_syntree = 1;
-	    }
-	    if ($arg >= 2) {
-		$bypass_nullops = 1;
-	    }
-	    if ($arg >= 1) {
-		$compress_nullops = 1;
-		$omit_seq = 1;
-	    }
-	} elsif ($opt eq "P") {
-	    $arg ||= shift @options;
-	    push @packages, $arg;
+	    close $f;
 	}
     }
-    if (! @packages) {
-	warn "No package specified for compilation, assuming main::\n";
-	@packages = qw(main);
-    }
-    if (@options) { # XXX: unsupported and untested!
-	return sub {
-	    my $objname;
-	    my $newfh; 
-	    $newfh = prepare_assemble() unless $no_assemble;
-	    foreach $objname (@options) {
-		eval "bytecompile_object(\\$objname)";
+    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";
 	    }
-	    do_assemble($newfh) unless $no_assemble;
-	}
-    } else {
-	return sub {
-	    my $newfh; 
-	    $newfh = prepare_assemble() unless $no_assemble;
-	    bytecompile_main();
-	    do_assemble($newfh) unless $no_assemble;
 	}
+
+	endasm;
     }
 }
 
 1;
-
-__END__
-
-=head1 NAME
-
-B::Bytecode - Perl compiler's bytecode backend
-
-=head1 SYNOPSIS
-
-	perl -MO=Bytecode[,OPTIONS] foo.pl
-
-=head1 DESCRIPTION
-
-This compiler backend takes Perl source and generates a
-platform-independent bytecode encapsulating code to load the
-internal structures perl uses to run your program. When the
-generated bytecode is loaded in, your program is ready to run,
-reducing the time which perl would have taken to load and parse
-your program into its internal semi-compiled form. That means that
-compiling with this backend will not help improve the runtime
-execution speed of your program but may improve the start-up time.
-Depending on the environment in which your program runs this may
-or may not be a help.
-
-The resulting bytecode can be run with a special byteperl executable
-or (for non-main programs) be loaded via the C<byteload_fh> function
-in the F<B> module.
-
-=head1 OPTIONS
-
-If there are any non-option arguments, they are taken to be names of
-objects to be saved (probably doesn't work properly yet).  Without
-extra arguments, it saves the main program.
-
-=over 4
-
-=item B<-ofilename>
-
-Output to filename instead of STDOUT.
-
-=item B<-afilename>
-
-Append output to filename.
-
-=item B<-->
-
-Force end of options.
-
-=item B<-f>
-
-Force optimisations on or off one at a time. Each can be preceded
-by B<no-> to turn the option off (e.g. B<-fno-compress-nullops>).
-
-=item B<-fcompress-nullops>
-
-Only fills in the necessary fields of ops which have
-been optimised away by perl's internal compiler.
-
-=item B<-fomit-sequence-numbers>
-
-Leaves out code to fill in the op_seq field of all ops
-which is only used by perl's internal compiler.
-
-=item B<-fbypass-nullops>
-
-If op->op_next ever points to a NULLOP, replaces the op_next field
-with the first non-NULLOP in the path of execution.
-
-=item B<-fstrip-syntax-tree>
-
-Leaves out code to fill in the pointers which link the internal syntax
-tree together. They're not needed at run-time but leaving them out
-will make it impossible to recompile or disassemble the resulting
-program.  It will also stop C<goto label> statements from working.
-
-=item B<-On>
-
-Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
-B<-O1> sets B<-fcompress-nullops> B<-fomit-sequence numbers>.
-B<-O6> adds B<-fstrip-syntax-tree>.
-
-=item B<-D>
-
-Debug options (concatenated or separate flags like C<perl -D>).
-
-=item B<-Do>
-
-Prints each OP as it's processed.
-
-=item B<-Db>
-
-Print debugging information about bytecompiler progress.
-
-=item B<-Da>
-
-Tells the (bytecode) assembler to include source assembler lines
-in its output as bytecode comments.
-
-=item B<-DC>
-
-Prints each CV taken from the final symbol tree walk.
-
-=item B<-S>
-
-Output (bytecode) assembler source rather than piping it
-through the assembler and outputting bytecode.
-
-=item B<-Ppackage>
-  
-Stores package in the output.
-  
-=back
-
-=head1 EXAMPLES
-
-    perl -MO=Bytecode,-O6,-ofoo.plc,-Pmain foo.pl
-
-    perl -MO=Bytecode,-S,-Pmain foo.pl > foo.S
-    assemble foo.S > foo.plc
-
-Note that C<assemble> lives in the C<B> subdirectory of your perl
-library directory. The utility called perlcc may also be used to 
-help make use of this compiler.
-
-    perl -MO=Bytecode,-PFoo,-oFoo.pmc Foo.pm
-
-=head1 BUGS
-
-Output is still huge and there are still occasional crashes during
-either compilation or ByteLoading. Current status: experimental.
-
-=head1 AUTHORS
-
-Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
-Benjamin Stuhl, C<sho_pi@hotmail.com>
-
-=cut