[asperl] integrate latest win32 branch

p4raw-id: //depot/asperl@569

39 files changed, 8876 insertions, 0 deletions

diff --git a/ext/B/B.pm b/ext/B/B.pm
new file mode 100644
index 0000000000..8545c5c847
--- /dev/null
+++ b/ext/B/B.pm
@@ -0,0 +1,271 @@
+#      B.pm
+#
+#      Copyright (c) 1996, 1997 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.
+#
+package B;
+require DynaLoader;
+require Exporter;
+@ISA = qw(Exporter DynaLoader);
+@EXPORT_OK = qw(byteload_fh byteload_string minus_c ppname
+		class peekop cast_I32 cstring cchar hash threadsv_names
+		main_root main_start main_cv svref_2object
+		walkoptree walkoptree_slow walkoptree_exec walksymtable
+		parents comppadlist sv_undef compile_stats timing_info);
+
+use strict;
+@B::SV::ISA = 'B::OBJECT';
+@B::NULL::ISA = 'B::SV';
+@B::PV::ISA = 'B::SV';
+@B::IV::ISA = 'B::SV';
+@B::NV::ISA = 'B::IV';
+@B::RV::ISA = 'B::SV';
+@B::PVIV::ISA = qw(B::PV B::IV);
+@B::PVNV::ISA = qw(B::PV B::NV);
+@B::PVMG::ISA = 'B::PVNV';
+@B::PVLV::ISA = 'B::PVMG';
+@B::BM::ISA = 'B::PVMG';
+@B::AV::ISA = 'B::PVMG';
+@B::GV::ISA = 'B::PVMG';
+@B::HV::ISA = 'B::PVMG';
+@B::CV::ISA = 'B::PVMG';
+@B::IO::ISA = 'B::CV';
+
+@B::OP::ISA = 'B::OBJECT';
+@B::UNOP::ISA = 'B::OP';
+@B::BINOP::ISA = 'B::UNOP';
+@B::LOGOP::ISA = 'B::UNOP';
+@B::CONDOP::ISA = 'B::UNOP';
+@B::LISTOP::ISA = 'B::BINOP';
+@B::SVOP::ISA = 'B::OP';
+@B::GVOP::ISA = 'B::OP';
+@B::PVOP::ISA = 'B::OP';
+@B::CVOP::ISA = 'B::OP';
+@B::LOOP::ISA = 'B::LISTOP';
+@B::PMOP::ISA = 'B::LISTOP';
+@B::COP::ISA = 'B::OP';
+
+@B::SPECIAL::ISA = 'B::OBJECT';
+
+{
+    # Stop "-w" from complaining about the lack of a real B::OBJECT class
+    package B::OBJECT;
+}
+
+my $debug;
+my $op_count = 0;
+my @parents = ();
+
+sub debug {
+    my ($class, $value) = @_;
+    $debug = $value;
+    walkoptree_debug($value);
+}
+
+# sub OPf_KIDS;
+# add to .xs for perl5.002
+sub OPf_KIDS () { 4 }
+
+sub class {
+    my $obj = shift;
+    my $name = ref $obj;
+    $name =~ s/^.*:://;
+    return $name;
+}
+
+sub parents { \@parents }
+
+# For debugging
+sub peekop {
+    my $op = shift;
+    return sprintf("%s (0x%x) %s", class($op), $$op, $op->ppaddr);
+}
+
+sub walkoptree_slow {
+    my($op, $method, $level) = @_;
+    $op_count++; # just for statistics
+    $level ||= 0;
+    warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug;
+    $op->$method($level);
+    if ($$op && ($op->flags & OPf_KIDS)) {
+	my $kid;
+	unshift(@parents, $op);
+	for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
+	    walkoptree_slow($kid, $method, $level + 1);
+	}
+	shift @parents;
+    }
+}
+
+sub compile_stats {
+    return "Total number of OPs processed: $op_count\n";
+}
+
+sub timing_info {
+    my ($sec, $min, $hr) = localtime;
+    my ($user, $sys) = times;
+    sprintf("%02d:%02d:%02d user=$user sys=$sys",
+	    $hr, $min, $sec, $user, $sys);
+}
+
+my %symtable;
+sub savesym {
+    my ($obj, $value) = @_;
+#    warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug
+    $symtable{sprintf("sym_%x", $$obj)} = $value;
+}
+
+sub objsym {
+    my $obj = shift;
+    return $symtable{sprintf("sym_%x", $$obj)};
+}
+
+sub walkoptree_exec {
+    my ($op, $method, $level) = @_;
+    my ($sym, $ppname);
+    my $prefix = "    " x $level;
+    for (; $$op; $op = $op->next) {
+	$sym = objsym($op);
+	if (defined($sym)) {
+	    print $prefix, "goto $sym\n";
+	    return;
+	}
+	savesym($op, sprintf("%s (0x%lx)", class($op), $$op));
+	$op->$method($level);
+	$ppname = $op->ppaddr;
+	if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile|entertry)$/) {
+	    print $prefix, uc($1), " => {\n";
+	    walkoptree_exec($op->other, $method, $level + 1);
+	    print $prefix, "}\n";
+	} elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") {
+	    my $pmreplstart = $op->pmreplstart;
+	    if ($$pmreplstart) {
+		print $prefix, "PMREPLSTART => {\n";
+		walkoptree_exec($pmreplstart, $method, $level + 1);
+		print $prefix, "}\n";
+	    }
+	} elsif ($ppname eq "pp_substcont") {
+	    print $prefix, "SUBSTCONT => {\n";
+	    walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
+	    print $prefix, "}\n";
+	    $op = $op->other;
+	} elsif ($ppname eq "pp_cond_expr") {
+	    # pp_cond_expr never returns op_next
+	    print $prefix, "TRUE => {\n";
+	    walkoptree_exec($op->true, $method, $level + 1);
+	    print $prefix, "}\n";
+	    $op = $op->false;
+	    redo;
+	} elsif ($ppname eq "pp_range") {
+	    print $prefix, "TRUE => {\n";
+	    walkoptree_exec($op->true, $method, $level + 1);
+	    print $prefix, "}\n", $prefix, "FALSE => {\n";
+	    walkoptree_exec($op->false, $method, $level + 1);
+	    print $prefix, "}\n";
+	} elsif ($ppname eq "pp_enterloop") {
+	    print $prefix, "REDO => {\n";
+	    walkoptree_exec($op->redoop, $method, $level + 1);
+	    print $prefix, "}\n", $prefix, "NEXT => {\n";
+	    walkoptree_exec($op->nextop, $method, $level + 1);
+	    print $prefix, "}\n", $prefix, "LAST => {\n";
+	    walkoptree_exec($op->lastop,  $method, $level + 1);
+	    print $prefix, "}\n";
+	} elsif ($ppname eq "pp_subst") {
+	    my $replstart = $op->pmreplstart;
+	    if ($$replstart) {
+		print $prefix, "SUBST => {\n";
+		walkoptree_exec($replstart, $method, $level + 1);
+		print $prefix, "}\n";
+	    }
+	}
+    }
+}
+
+sub walksymtable {
+    my ($symref, $method, $recurse, $prefix) = @_;
+    my $sym;
+    no strict 'vars';
+    local(*glob);
+    while (($sym, *glob) = each %$symref) {
+	if ($sym =~ /::$/) {
+	    $sym = $prefix . $sym;
+	    if ($sym ne "main::" && &$recurse($sym)) {
+		walksymtable(\%glob, $method, $recurse, $sym);
+	    }
+	} else {
+	    svref_2object(\*glob)->EGV->$method();
+	}
+    }
+}
+
+{
+    package B::Section;
+    my $output_fh;
+    my %sections;
+    
+    sub new {
+	my ($class, $section, $symtable, $default) = @_;
+	$output_fh ||= FileHandle->new_tmpfile;
+	my $obj = bless [-1, $section, $symtable, $default], $class;
+	$sections{$section} = $obj;
+	return $obj;
+    }
+    
+    sub get {
+	my ($class, $section) = @_;
+	return $sections{$section};
+    }
+
+    sub add {
+	my $section = shift;
+	while (defined($_ = shift)) {
+	    print $output_fh "$section->[1]\t$_\n";
+	    $section->[0]++;
+	}
+    }
+
+    sub index {
+	my $section = shift;
+	return $section->[0];
+    }
+
+    sub name {
+	my $section = shift;
+	return $section->[1];
+    }
+
+    sub symtable {
+	my $section = shift;
+	return $section->[2];
+    }
+	
+    sub default {
+	my $section = shift;
+	return $section->[3];
+    }
+	
+    sub output {
+	my ($section, $fh, $format) = @_;
+	my $name = $section->name;
+	my $sym = $section->symtable || {};
+	my $default = $section->default;
+
+	seek($output_fh, 0, 0);
+	while (<$output_fh>) {
+	    chomp;
+	    s/^(.*?)\t//;
+	    if ($1 eq $name) {
+		s{(s\\_[0-9a-f]+)} {
+		    exists($sym->{$1}) ? $sym->{$1} : $default;
+		}ge;
+		printf $fh $format, $_;
+	    }
+	}
+    }
+}
+
+bootstrap B;
+
+1;
diff --git a/ext/B/B.xs b/ext/B/B.xs
new file mode 100644
index 0000000000..0bb7acba02
--- /dev/null
+++ b/ext/B/B.xs
@@ -0,0 +1,1207 @@
+/*	B.xs
+ *
+ *	Copyright (c) 1996 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.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include "INTERN.h"
+#include "bytecode.h"
+#include "byterun.h"
+
+static char *svclassnames[] = {
+    "B::NULL",
+    "B::IV",
+    "B::NV",
+    "B::RV",
+    "B::PV",
+    "B::PVIV",
+    "B::PVNV",
+    "B::PVMG",
+    "B::BM",
+    "B::PVLV",
+    "B::AV",
+    "B::HV",
+    "B::CV",
+    "B::GV",
+    "B::FM",
+    "B::IO",
+};
+
+typedef enum {
+    OPc_NULL,	/* 0 */
+    OPc_BASEOP,	/* 1 */
+    OPc_UNOP,	/* 2 */
+    OPc_BINOP,	/* 3 */
+    OPc_LOGOP,	/* 4 */
+    OPc_CONDOP,	/* 5 */
+    OPc_LISTOP,	/* 6 */
+    OPc_PMOP,	/* 7 */
+    OPc_SVOP,	/* 8 */
+    OPc_GVOP,	/* 9 */
+    OPc_PVOP,	/* 10 */
+    OPc_CVOP,	/* 11 */
+    OPc_LOOP,	/* 12 */
+    OPc_COP	/* 13 */
+} opclass;
+
+static char *opclassnames[] = {
+    "B::NULL",
+    "B::OP",
+    "B::UNOP",
+    "B::BINOP",
+    "B::LOGOP",
+    "B::CONDOP",
+    "B::LISTOP",
+    "B::PMOP",
+    "B::SVOP",
+    "B::GVOP",
+    "B::PVOP",
+    "B::CVOP",
+    "B::LOOP",
+    "B::COP"	
+};
+
+static int walkoptree_debug = 0;	/* Flag for walkoptree debug hook */
+
+static opclass
+cc_opclass(OP *o)
+{
+    if (!o)
+	return OPc_NULL;
+
+    if (o->op_type == 0)
+	return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
+
+    if (o->op_type == OP_SASSIGN)
+	return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
+
+    switch (opargs[o->op_type] & OA_CLASS_MASK) {
+    case OA_BASEOP:
+	return OPc_BASEOP;
+
+    case OA_UNOP:
+	return OPc_UNOP;
+
+    case OA_BINOP:
+	return OPc_BINOP;
+
+    case OA_LOGOP:
+	return OPc_LOGOP;
+
+    case OA_CONDOP:
+	return OPc_CONDOP;
+
+    case OA_LISTOP:
+	return OPc_LISTOP;
+
+    case OA_PMOP:
+	return OPc_PMOP;
+
+    case OA_SVOP:
+	return OPc_SVOP;
+
+    case OA_GVOP:
+	return OPc_GVOP;
+
+    case OA_PVOP:
+	return OPc_PVOP;
+
+    case OA_LOOP:
+	return OPc_LOOP;
+
+    case OA_COP:
+	return OPc_COP;
+
+    case OA_BASEOP_OR_UNOP:
+	/*
+	 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
+	 * whether bare parens were seen. perly.y uses OPf_SPECIAL to
+	 * signal whether an OP or an UNOP was chosen.
+	 * Frederic.Chauveau@pasteur.fr says we need to check for OPf_KIDS too.
+	 */
+	return ((o->op_flags & OPf_SPECIAL) ? OPc_BASEOP :
+		(o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP);
+
+    case OA_FILESTATOP:
+	/*
+	 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
+	 * the OPf_REF flag to distinguish between OP types instead of the
+	 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
+	 * return OPc_UNOP so that walkoptree can find our children. If
+	 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
+	 * (no argument to the operator) it's an OP; with OPf_REF set it's
+	 * a GVOP (and op_gv is the GV for the filehandle argument).
+	 */
+	return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
+		(o->op_flags & OPf_REF) ? OPc_GVOP : OPc_BASEOP);
+
+    case OA_LOOPEXOP:
+	/*
+	 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
+	 * label was omitted (in which case it's a BASEOP) or else a term was
+	 * seen. In this last case, all except goto are definitely PVOP but
+	 * goto is either a PVOP (with an ordinary constant label), an UNOP
+	 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
+	 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
+	 * get set.
+	 */
+	if (o->op_flags & OPf_STACKED)
+	    return OPc_UNOP;
+	else if (o->op_flags & OPf_SPECIAL)
+	    return OPc_BASEOP;
+	else
+	    return OPc_PVOP;
+    }
+    warn("can't determine class of operator %s, assuming BASEOP\n",
+	 op_name[o->op_type]);
+    return OPc_BASEOP;
+}
+
+static char *
+cc_opclassname(OP *o)
+{
+    return opclassnames[cc_opclass(o)];
+}
+
+static SV *
+make_sv_object(SV *arg, SV *sv)
+{
+    char *type = 0;
+    IV iv;
+    
+    for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) {
+	if (sv == specialsv_list[iv]) {
+	    type = "B::SPECIAL";
+	    break;
+	}
+    }
+    if (!type) {
+	type = svclassnames[SvTYPE(sv)];
+	iv = (IV)sv;
+    }
+    sv_setiv(newSVrv(arg, type), iv);
+    return arg;
+}
+
+static SV *
+make_mg_object(SV *arg, MAGIC *mg)
+{
+    sv_setiv(newSVrv(arg, "B::MAGIC"), (IV)mg);
+    return arg;
+}
+
+static SV *
+cstring(SV *sv)
+{
+    SV *sstr = newSVpv("", 0);
+    STRLEN len;
+    char *s;
+
+    if (!SvOK(sv))
+	sv_setpvn(sstr, "0", 1);
+    else
+    {
+	/* XXX Optimise? */
+	s = SvPV(sv, len);
+	sv_catpv(sstr, "\"");
+	for (; len; len--, s++)
+	{
+	    /* At least try a little for readability */
+	    if (*s == '"')
+		sv_catpv(sstr, "\\\"");
+	    else if (*s == '\\')
+		sv_catpv(sstr, "\\\\");
+	    else if (*s >= ' ' && *s < 127) /* XXX not portable */
+		sv_catpvn(sstr, s, 1);
+	    else if (*s == '\n')
+		sv_catpv(sstr, "\\n");
+	    else if (*s == '\r')
+		sv_catpv(sstr, "\\r");
+	    else if (*s == '\t')
+		sv_catpv(sstr, "\\t");
+	    else if (*s == '\a')
+		sv_catpv(sstr, "\\a");
+	    else if (*s == '\b')
+		sv_catpv(sstr, "\\b");
+	    else if (*s == '\f')
+		sv_catpv(sstr, "\\f");
+	    else if (*s == '\v')
+		sv_catpv(sstr, "\\v");
+	    else
+	    {
+		/* no trigraph support */
+		char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
+		/* Don't want promotion of a signed -1 char in sprintf args */
+		unsigned char c = (unsigned char) *s;
+		sprintf(escbuff, "\\%03o", c);
+		sv_catpv(sstr, escbuff);
+	    }
+	    /* XXX Add line breaks if string is long */
+	}
+	sv_catpv(sstr, "\"");
+    }
+    return sstr;
+}
+
+static SV *
+cchar(SV *sv)
+{
+    SV *sstr = newSVpv("'", 0);
+    char *s = SvPV(sv, na);
+
+    if (*s == '\'')
+	sv_catpv(sstr, "\\'");
+    else if (*s == '\\')
+	sv_catpv(sstr, "\\\\");
+    else if (*s >= ' ' && *s < 127) /* XXX not portable */
+	sv_catpvn(sstr, s, 1);
+    else if (*s == '\n')
+	sv_catpv(sstr, "\\n");
+    else if (*s == '\r')
+	sv_catpv(sstr, "\\r");
+    else if (*s == '\t')
+	sv_catpv(sstr, "\\t");
+    else if (*s == '\a')
+	sv_catpv(sstr, "\\a");
+    else if (*s == '\b')
+	sv_catpv(sstr, "\\b");
+    else if (*s == '\f')
+	sv_catpv(sstr, "\\f");
+    else if (*s == '\v')
+	sv_catpv(sstr, "\\v");
+    else
+    {
+	/* no trigraph support */
+	char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
+	/* Don't want promotion of a signed -1 char in sprintf args */
+	unsigned char c = (unsigned char) *s;
+	sprintf(escbuff, "\\%03o", c);
+	sv_catpv(sstr, escbuff);
+    }
+    sv_catpv(sstr, "'");
+    return sstr;
+}
+
+void *
+bset_obj_store(void *obj, I32 ix)
+{
+    if (ix > obj_list_fill) {
+	if (obj_list_fill == -1)
+	    New(666, obj_list, ix + 1, void*);
+	else
+	    Renew(obj_list, ix + 1, void*);
+	obj_list_fill = ix;
+    }
+    obj_list[ix] = obj;
+    return obj;
+}
+
+#ifdef INDIRECT_BGET_MACROS
+void freadpv(U32 len, void *data)
+{
+    New(666, pv.xpv_pv, len, char);
+    fread(pv.xpv_pv, 1, len, (FILE*)data);
+    pv.xpv_len = len;
+    pv.xpv_cur = len - 1;
+}
+
+void byteload_fh(FILE *fp)
+{
+    struct bytestream bs;
+    bs.data = fp;
+    bs.fgetc = (int(*) _((void*)))fgetc;
+    bs.fread = (int(*) _((char*,size_t,size_t,void*)))fread;
+    bs.freadpv = freadpv;
+    byterun(bs);
+}
+
+static int fgetc_fromstring(void *data)
+{
+    char **strp = (char **)data;
+    return *(*strp)++;
+}
+
+static int fread_fromstring(char *argp, size_t elemsize, size_t nelem,
+			    void *data)
+{
+    char **strp = (char **)data;
+    size_t len = elemsize * nelem;
+    
+    memcpy(argp, *strp, len);
+    *strp += len;
+    return (int)len;
+}
+
+static void freadpv_fromstring(U32 len, void *data)
+{
+    char **strp = (char **)data;
+    
+    New(666, pv.xpv_pv, len, char);
+    memcpy(pv.xpv_pv, *strp, len);
+    pv.xpv_len = len;
+    pv.xpv_cur = len - 1;
+    *strp += len;
+}    
+
+void byteload_string(char *str)
+{
+    struct bytestream bs;
+    bs.data = &str;
+    bs.fgetc = fgetc_fromstring;
+    bs.fread = fread_fromstring;
+    bs.freadpv = freadpv_fromstring;
+    byterun(bs);
+}
+#else
+void byteload_fh(FILE *fp)
+{
+    byterun(fp);
+}
+
+void byteload_string(char *str)
+{
+    croak("Must compile with -DINDIRECT_BGET_MACROS for byteload_string");
+}    
+#endif /* INDIRECT_BGET_MACROS */
+
+void
+walkoptree(SV *opsv, char *method)
+{
+    dSP;
+    OP *o;
+    
+    if (!SvROK(opsv))
+	croak("opsv is not a reference");
+    opsv = sv_mortalcopy(opsv);
+    o = (OP*)SvIV((SV*)SvRV(opsv));
+    if (walkoptree_debug) {
+	PUSHMARK(sp);
+	XPUSHs(opsv);
+	PUTBACK;
+	perl_call_method("walkoptree_debug", G_DISCARD);
+    }
+    PUSHMARK(sp);
+    XPUSHs(opsv);
+    PUTBACK;
+    perl_call_method(method, G_DISCARD);
+    if (o && (o->op_flags & OPf_KIDS)) {
+	OP *kid;
+	for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) {
+	    /* Use the same opsv. Rely on methods not to mess it up. */
+	    sv_setiv(newSVrv(opsv, cc_opclassname(kid)), (IV)kid);
+	    walkoptree(opsv, method);
+	}
+    }
+}
+
+typedef OP	*B__OP;
+typedef UNOP	*B__UNOP;
+typedef BINOP	*B__BINOP;
+typedef LOGOP	*B__LOGOP;
+typedef CONDOP	*B__CONDOP;
+typedef LISTOP	*B__LISTOP;
+typedef PMOP	*B__PMOP;
+typedef SVOP	*B__SVOP;
+typedef GVOP	*B__GVOP;
+typedef PVOP	*B__PVOP;
+typedef LOOP	*B__LOOP;
+typedef COP	*B__COP;
+
+typedef SV	*B__SV;
+typedef SV	*B__IV;
+typedef SV	*B__PV;
+typedef SV	*B__NV;
+typedef SV	*B__PVMG;
+typedef SV	*B__PVLV;
+typedef SV	*B__BM;
+typedef SV	*B__RV;
+typedef AV	*B__AV;
+typedef HV	*B__HV;
+typedef CV	*B__CV;
+typedef GV	*B__GV;
+typedef IO	*B__IO;
+
+typedef MAGIC	*B__MAGIC;
+
+MODULE = B	PACKAGE = B	PREFIX = B_
+
+PROTOTYPES: DISABLE
+
+BOOT:
+    INIT_SPECIALSV_LIST;
+
+#define B_main_cv()	main_cv
+#define B_main_root()	main_root
+#define B_main_start()	main_start
+#define B_comppadlist()	(main_cv ? CvPADLIST(main_cv) : CvPADLIST(compcv))
+#define B_sv_undef()	&sv_undef
+#define B_sv_yes()	&sv_yes
+#define B_sv_no()	&sv_no
+
+B::CV
+B_main_cv()
+
+B::OP
+B_main_root()
+
+B::OP
+B_main_start()
+
+B::AV
+B_comppadlist()
+
+B::SV
+B_sv_undef()
+
+B::SV
+B_sv_yes()
+
+B::SV
+B_sv_no()
+
+MODULE = B	PACKAGE = B
+
+
+void
+walkoptree(opsv, method)
+	SV *	opsv
+	char *	method
+
+int
+walkoptree_debug(...)
+    CODE:
+	RETVAL = walkoptree_debug;
+	if (items > 0 && SvTRUE(ST(1)))
+	    walkoptree_debug = 1;
+    OUTPUT:
+	RETVAL
+
+int
+byteload_fh(fp)
+	FILE *	fp
+    CODE:
+	byteload_fh(fp);
+	RETVAL = 1;
+    OUTPUT:
+	RETVAL
+
+void
+byteload_string(str)
+	char *	str
+
+#define address(sv) (IV)sv
+
+IV
+address(sv)
+	SV *	sv
+
+B::SV
+svref_2object(sv)
+	SV *	sv
+    CODE:
+	if (!SvROK(sv))
+	    croak("argument is not a reference");
+	RETVAL = (SV*)SvRV(sv);
+    OUTPUT:
+	RETVAL
+
+void
+ppname(opnum)
+	int	opnum
+    CODE:
+	ST(0) = sv_newmortal();
+	if (opnum >= 0 && opnum < maxo) {
+	    sv_setpvn(ST(0), "pp_", 3);
+	    sv_catpv(ST(0), op_name[opnum]);
+	}
+
+void
+hash(sv)
+	SV *	sv
+    CODE:
+	char *s;
+	STRLEN len;
+	U32 hash = 0;
+	char hexhash[11]; /* must fit "0xffffffff" plus trailing \0 */
+	s = SvPV(sv, len);
+	while (len--)
+	    hash = hash * 33 + *s++;
+	sprintf(hexhash, "0x%x", hash);
+	ST(0) = sv_2mortal(newSVpv(hexhash, 0));
+
+#define cast_I32(foo) (I32)foo
+IV
+cast_I32(i)
+	IV	i
+
+void
+minus_c()
+    CODE:
+	minus_c = TRUE;
+
+SV *
+cstring(sv)
+	SV *	sv
+
+SV *
+cchar(sv)
+	SV *	sv
+
+void
+threadsv_names()
+    PPCODE:
+#ifdef USE_THREADS
+	int i;
+	STRLEN len = strlen(threadsv_names);
+
+	EXTEND(sp, len);
+	for (i = 0; i < len; i++)
+	    PUSHs(sv_2mortal(newSVpv(&threadsv_names[i], 1)));
+#endif
+
+
+#define OP_next(o)	o->op_next
+#define OP_sibling(o)	o->op_sibling
+#define OP_desc(o)	op_desc[o->op_type]
+#define OP_targ(o)	o->op_targ
+#define OP_type(o)	o->op_type
+#define OP_seq(o)	o->op_seq
+#define OP_flags(o)	o->op_flags
+#define OP_private(o)	o->op_private
+
+MODULE = B	PACKAGE = B::OP		PREFIX = OP_
+
+B::OP
+OP_next(o)
+	B::OP		o
+
+B::OP
+OP_sibling(o)
+	B::OP		o
+
+char *
+OP_ppaddr(o)
+	B::OP		o
+    CODE:
+	ST(0) = sv_newmortal();
+	sv_setpvn(ST(0), "pp_", 3);
+	sv_catpv(ST(0), op_name[o->op_type]);
+
+char *
+OP_desc(o)
+	B::OP		o
+
+U16
+OP_targ(o)
+	B::OP		o
+
+U16
+OP_type(o)
+	B::OP		o
+
+U16
+OP_seq(o)
+	B::OP		o
+
+U8
+OP_flags(o)
+	B::OP		o
+
+U8
+OP_private(o)
+	B::OP		o
+
+#define UNOP_first(o)	o->op_first
+
+MODULE = B	PACKAGE = B::UNOP		PREFIX = UNOP_
+
+B::OP 
+UNOP_first(o)
+	B::UNOP	o
+
+#define BINOP_last(o)	o->op_last
+
+MODULE = B	PACKAGE = B::BINOP		PREFIX = BINOP_
+
+B::OP
+BINOP_last(o)
+	B::BINOP	o
+
+#define LOGOP_other(o)	o->op_other
+
+MODULE = B	PACKAGE = B::LOGOP		PREFIX = LOGOP_
+
+B::OP
+LOGOP_other(o)
+	B::LOGOP	o
+
+#define CONDOP_true(o)	o->op_true
+#define CONDOP_false(o)	o->op_false
+
+MODULE = B	PACKAGE = B::CONDOP		PREFIX = CONDOP_
+
+B::OP
+CONDOP_true(o)
+	B::CONDOP	o
+
+B::OP
+CONDOP_false(o)
+	B::CONDOP	o
+
+#define LISTOP_children(o)	o->op_children
+
+MODULE = B	PACKAGE = B::LISTOP		PREFIX = LISTOP_
+
+U32
+LISTOP_children(o)
+	B::LISTOP	o
+
+#define PMOP_pmreplroot(o)	o->op_pmreplroot
+#define PMOP_pmreplstart(o)	o->op_pmreplstart
+#define PMOP_pmnext(o)		o->op_pmnext
+#define PMOP_pmregexp(o)	o->op_pmregexp
+#define PMOP_pmflags(o)		o->op_pmflags
+#define PMOP_pmpermflags(o)	o->op_pmpermflags
+
+MODULE = B	PACKAGE = B::PMOP		PREFIX = PMOP_
+
+void
+PMOP_pmreplroot(o)
+	B::PMOP		o
+	OP *		root = NO_INIT
+    CODE:
+	ST(0) = sv_newmortal();
+	root = o->op_pmreplroot;
+	/* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
+	if (o->op_type == OP_PUSHRE) {
+	    sv_setiv(newSVrv(ST(0), root ?
+			     svclassnames[SvTYPE((SV*)root)] : "B::SV"),
+		     (IV)root);
+	}
+	else {
+	    sv_setiv(newSVrv(ST(0), cc_opclassname(root)), (IV)root);
+	}
+
+B::OP
+PMOP_pmreplstart(o)
+	B::PMOP		o
+
+B::PMOP
+PMOP_pmnext(o)
+	B::PMOP		o
+
+U16
+PMOP_pmflags(o)
+	B::PMOP		o
+
+U16
+PMOP_pmpermflags(o)
+	B::PMOP		o
+
+void
+PMOP_precomp(o)
+	B::PMOP		o
+	REGEXP *	rx = NO_INIT
+    CODE:
+	ST(0) = sv_newmortal();
+	rx = o->op_pmregexp;
+	if (rx)
+	    sv_setpvn(ST(0), rx->precomp, rx->prelen);
+
+#define SVOP_sv(o)	o->op_sv
+
+MODULE = B	PACKAGE = B::SVOP		PREFIX = SVOP_
+
+
+B::SV
+SVOP_sv(o)
+	B::SVOP	o
+
+#define GVOP_gv(o)	o->op_gv
+
+MODULE = B	PACKAGE = B::GVOP		PREFIX = GVOP_
+
+
+B::GV
+GVOP_gv(o)
+	B::GVOP	o
+
+MODULE = B	PACKAGE = B::PVOP		PREFIX = PVOP_
+
+void
+PVOP_pv(o)
+	B::PVOP	o
+    CODE:
+	/*
+	 * OP_TRANS uses op_pv to point to a table of 256 shorts
+	 * whereas other PVOPs point to a null terminated string.
+	 */
+	ST(0) = sv_2mortal(newSVpv(o->op_pv, (o->op_type == OP_TRANS) ?
+				   256 * sizeof(short) : 0));
+
+#define LOOP_redoop(o)	o->op_redoop
+#define LOOP_nextop(o)	o->op_nextop
+#define LOOP_lastop(o)	o->op_lastop
+
+MODULE = B	PACKAGE = B::LOOP		PREFIX = LOOP_
+
+
+B::OP
+LOOP_redoop(o)
+	B::LOOP	o
+
+B::OP
+LOOP_nextop(o)
+	B::LOOP	o
+
+B::OP
+LOOP_lastop(o)
+	B::LOOP	o
+
+#define COP_label(o)	o->cop_label
+#define COP_stash(o)	o->cop_stash
+#define COP_filegv(o)	o->cop_filegv
+#define COP_cop_seq(o)	o->cop_seq
+#define COP_arybase(o)	o->cop_arybase
+#define COP_line(o)	o->cop_line
+
+MODULE = B	PACKAGE = B::COP		PREFIX = COP_
+
+char *
+COP_label(o)
+	B::COP	o
+
+B::HV
+COP_stash(o)
+	B::COP	o
+
+B::GV
+COP_filegv(o)
+	B::COP	o
+
+U32
+COP_cop_seq(o)
+	B::COP	o
+
+I32
+COP_arybase(o)
+	B::COP	o
+
+U16
+COP_line(o)
+	B::COP	o
+
+MODULE = B	PACKAGE = B::SV		PREFIX = Sv
+
+U32
+SvREFCNT(sv)
+	B::SV	sv
+
+U32
+SvFLAGS(sv)
+	B::SV	sv
+
+MODULE = B	PACKAGE = B::IV		PREFIX = Sv
+
+IV
+SvIV(sv)
+	B::IV	sv
+
+IV
+SvIVX(sv)
+	B::IV	sv
+
+MODULE = B	PACKAGE = B::IV
+
+#define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv))
+
+int
+needs64bits(sv)
+	B::IV	sv
+
+void
+packiv(sv)
+	B::IV	sv
+    CODE:
+	if (sizeof(IV) == 8) {
+	    U32 wp[2];
+	    IV iv = SvIVX(sv);
+	    /*
+	     * The following way of spelling 32 is to stop compilers on
+	     * 32-bit architectures from moaning about the shift count
+	     * being >= the width of the type. Such architectures don't
+	     * reach this code anyway (unless sizeof(IV) > 8 but then
+	     * everything else breaks too so I'm not fussed at the moment).
+	     */
+	    wp[0] = htonl(((U32)iv) >> (sizeof(IV)*4));
+	    wp[1] = htonl(iv & 0xffffffff);
+	    ST(0) = sv_2mortal(newSVpv((char *)wp, 8));
+	} else {
+	    U32 w = htonl((U32)SvIVX(sv));
+	    ST(0) = sv_2mortal(newSVpv((char *)&w, 4));
+	}
+
+MODULE = B	PACKAGE = B::NV		PREFIX = Sv
+
+double
+SvNV(sv)
+	B::NV	sv
+
+double
+SvNVX(sv)
+	B::NV	sv
+
+MODULE = B	PACKAGE = B::RV		PREFIX = Sv
+
+B::SV
+SvRV(sv)
+	B::RV	sv
+
+MODULE = B	PACKAGE = B::PV		PREFIX = Sv
+
+void
+SvPV(sv)
+	B::PV	sv
+    CODE:
+	ST(0) = sv_newmortal();
+	sv_setpvn(ST(0), SvPVX(sv), SvCUR(sv));
+
+MODULE = B	PACKAGE = B::PVMG	PREFIX = Sv
+
+void
+SvMAGIC(sv)
+	B::PVMG	sv
+	MAGIC *	mg = NO_INIT
+    PPCODE:
+	for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
+	    XPUSHs(make_mg_object(sv_newmortal(), mg));
+
+MODULE = B	PACKAGE = B::PVMG
+
+B::HV
+SvSTASH(sv)
+	B::PVMG	sv
+
+#define MgMOREMAGIC(mg) mg->mg_moremagic
+#define MgPRIVATE(mg) mg->mg_private
+#define MgTYPE(mg) mg->mg_type
+#define MgFLAGS(mg) mg->mg_flags
+#define MgOBJ(mg) mg->mg_obj
+
+MODULE = B	PACKAGE = B::MAGIC	PREFIX = Mg	
+
+B::MAGIC
+MgMOREMAGIC(mg)
+	B::MAGIC	mg
+
+U16
+MgPRIVATE(mg)
+	B::MAGIC	mg
+
+char
+MgTYPE(mg)
+	B::MAGIC	mg
+
+U8
+MgFLAGS(mg)
+	B::MAGIC	mg
+
+B::SV
+MgOBJ(mg)
+	B::MAGIC	mg
+
+void
+MgPTR(mg)
+	B::MAGIC	mg
+    CODE:
+	ST(0) = sv_newmortal();
+	if (mg->mg_ptr)
+	    sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
+
+MODULE = B	PACKAGE = B::PVLV	PREFIX = Lv
+
+U32
+LvTARGOFF(sv)
+	B::PVLV	sv
+
+U32
+LvTARGLEN(sv)
+	B::PVLV	sv
+
+char
+LvTYPE(sv)
+	B::PVLV	sv
+
+B::SV
+LvTARG(sv)
+	B::PVLV sv
+
+MODULE = B	PACKAGE = B::BM		PREFIX = Bm
+
+I32
+BmUSEFUL(sv)
+	B::BM	sv
+
+U16
+BmPREVIOUS(sv)
+	B::BM	sv
+
+U8
+BmRARE(sv)
+	B::BM	sv
+
+void
+BmTABLE(sv)
+	B::BM	sv
+	STRLEN	len = NO_INIT
+	char *	str = NO_INIT
+    CODE:
+	str = SvPV(sv, len);
+	/* Boyer-Moore table is just after string and its safety-margin \0 */
+	ST(0) = sv_2mortal(newSVpv(str + len + 1, 256));
+
+MODULE = B	PACKAGE = B::GV		PREFIX = Gv
+
+void
+GvNAME(gv)
+	B::GV	gv
+    CODE:
+	ST(0) = sv_2mortal(newSVpv(GvNAME(gv), GvNAMELEN(gv)));
+
+B::HV
+GvSTASH(gv)
+	B::GV	gv
+
+B::SV
+GvSV(gv)
+	B::GV	gv
+
+B::IO
+GvIO(gv)
+	B::GV	gv
+
+B::CV
+GvFORM(gv)
+	B::GV	gv
+
+B::AV
+GvAV(gv)
+	B::GV	gv
+
+B::HV
+GvHV(gv)
+	B::GV	gv
+
+B::GV
+GvEGV(gv)
+	B::GV	gv
+
+B::CV
+GvCV(gv)
+	B::GV	gv
+
+U32
+GvCVGEN(gv)
+	B::GV	gv
+
+U16
+GvLINE(gv)
+	B::GV	gv
+
+B::GV
+GvFILEGV(gv)
+	B::GV	gv
+
+MODULE = B	PACKAGE = B::GV
+
+U32
+GvREFCNT(gv)
+	B::GV	gv
+
+U8
+GvFLAGS(gv)
+	B::GV	gv
+
+MODULE = B	PACKAGE = B::IO		PREFIX = Io
+
+long
+IoLINES(io)
+	B::IO	io
+
+long
+IoPAGE(io)
+	B::IO	io
+
+long
+IoPAGE_LEN(io)
+	B::IO	io
+
+long
+IoLINES_LEFT(io)
+	B::IO	io
+
+char *
+IoTOP_NAME(io)
+	B::IO	io
+
+B::GV
+IoTOP_GV(io)
+	B::IO	io
+
+char *
+IoFMT_NAME(io)
+	B::IO	io
+
+B::GV
+IoFMT_GV(io)
+	B::IO	io
+
+char *
+IoBOTTOM_NAME(io)
+	B::IO	io
+
+B::GV
+IoBOTTOM_GV(io)
+	B::IO	io
+
+short
+IoSUBPROCESS(io)
+	B::IO	io
+
+MODULE = B	PACKAGE = B::IO
+
+char
+IoTYPE(io)
+	B::IO	io
+
+U8
+IoFLAGS(io)
+	B::IO	io
+
+MODULE = B	PACKAGE = B::AV		PREFIX = Av
+
+SSize_t
+AvFILL(av)
+	B::AV	av
+
+SSize_t
+AvMAX(av)
+	B::AV	av
+
+#define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
+
+IV
+AvOFF(av)
+	B::AV	av
+
+void
+AvARRAY(av)
+	B::AV	av
+    PPCODE:
+	if (AvFILL(av) >= 0) {
+	    SV **svp = AvARRAY(av);
+	    I32 i;
+	    for (i = 0; i <= AvFILL(av); i++)
+		XPUSHs(make_sv_object(sv_newmortal(), svp[i]));
+	}
+
+MODULE = B	PACKAGE = B::AV
+
+U8
+AvFLAGS(av)
+	B::AV	av
+
+MODULE = B	PACKAGE = B::CV		PREFIX = Cv
+
+B::HV
+CvSTASH(cv)
+	B::CV	cv
+
+B::OP
+CvSTART(cv)
+	B::CV	cv
+
+B::OP
+CvROOT(cv)
+	B::CV	cv
+
+B::GV
+CvGV(cv)
+	B::CV	cv
+
+B::GV
+CvFILEGV(cv)
+	B::CV	cv
+
+long
+CvDEPTH(cv)
+	B::CV	cv
+
+B::AV
+CvPADLIST(cv)
+	B::CV	cv
+
+B::CV
+CvOUTSIDE(cv)
+	B::CV	cv
+
+void
+CvXSUB(cv)
+	B::CV	cv
+    CODE:
+	ST(0) = sv_2mortal(newSViv((IV)CvXSUB(cv)));
+
+
+void
+CvXSUBANY(cv)
+	B::CV	cv
+    CODE:
+	ST(0) = sv_2mortal(newSViv(CvXSUBANY(cv).any_iv));
+
+MODULE = B	PACKAGE = B::HV		PREFIX = Hv
+
+STRLEN
+HvFILL(hv)
+	B::HV	hv
+
+STRLEN
+HvMAX(hv)
+	B::HV	hv
+
+I32
+HvKEYS(hv)
+	B::HV	hv
+
+I32
+HvRITER(hv)
+	B::HV	hv
+
+char *
+HvNAME(hv)
+	B::HV	hv
+
+B::PMOP
+HvPMROOT(hv)
+	B::HV	hv
+
+void
+HvARRAY(hv)
+	B::HV	hv
+    PPCODE:
+	if (HvKEYS(hv) > 0) {
+	    SV *sv;
+	    char *key;
+	    I32 len;
+	    (void)hv_iterinit(hv);
+	    EXTEND(sp, HvKEYS(hv) * 2);
+	    while (sv = hv_iternextsv(hv, &key, &len)) {
+		PUSHs(newSVpv(key, len));
+		PUSHs(make_sv_object(sv_newmortal(), sv));
+	    }
+	}
diff --git a/ext/B/B/Asmdata.pm b/ext/B/B/Asmdata.pm
new file mode 100644
index 0000000000..3a3cf6da61
--- /dev/null
+++ b/ext/B/B/Asmdata.pm
@@ -0,0 +1,150 @@
+#
+#      Copyright (c) 1996, 1997 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.
+#
+#
+#
+# This file is autogenerated from bytecode.pl. Changes made here will be lost.
+#
+package B::Asmdata;
+use Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(%insn_data @insn_name @optype @specialsv_name);
+use vars qw(%insn_data @insn_name @optype @specialsv_name);
+
+@optype = qw(OP UNOP BINOP LOGOP CONDOP LISTOP PMOP SVOP GVOP PVOP LOOP COP);
+@specialsv_name = qw(Nullsv &sv_undef &sv_yes &sv_no);
+
+# XXX insn_data is initialised this way because with a large
+# %insn_data = (foo => [...], bar => [...], ...) initialiser
+# I get a hard-to-track-down stack underflow and segfault.
+$insn_data{comment} = [35, \&PUT_comment, "GET_comment"];
+$insn_data{nop} = [10, \&PUT_none, "GET_none"];
+$insn_data{ret} = [0, \&PUT_none, "GET_none"];
+$insn_data{ldsv} = [1, \&PUT_objindex, "GET_objindex"];
+$insn_data{ldop} = [2, \&PUT_objindex, "GET_objindex"];
+$insn_data{stsv} = [3, \&PUT_U32, "GET_U32"];
+$insn_data{stop} = [4, \&PUT_U32, "GET_U32"];
+$insn_data{ldspecsv} = [5, \&PUT_U8, "GET_U8"];
+$insn_data{newsv} = [6, \&PUT_U8, "GET_U8"];
+$insn_data{newop} = [7, \&PUT_U8, "GET_U8"];
+$insn_data{newopn} = [8, \&PUT_U8, "GET_U8"];
+$insn_data{newpv} = [9, \&PUT_PV, "GET_PV"];
+$insn_data{pv_cur} = [11, \&PUT_U32, "GET_U32"];
+$insn_data{pv_free} = [12, \&PUT_none, "GET_none"];
+$insn_data{sv_upgrade} = [13, \&PUT_U8, "GET_U8"];
+$insn_data{sv_refcnt} = [14, \&PUT_U32, "GET_U32"];
+$insn_data{sv_refcnt_add} = [15, \&PUT_I32, "GET_I32"];
+$insn_data{sv_flags} = [16, \&PUT_U32, "GET_U32"];
+$insn_data{xrv} = [17, \&PUT_objindex, "GET_objindex"];
+$insn_data{xpv} = [18, \&PUT_none, "GET_none"];
+$insn_data{xiv32} = [19, \&PUT_I32, "GET_I32"];
+$insn_data{xiv64} = [20, \&PUT_IV64, "GET_IV64"];
+$insn_data{xnv} = [21, \&PUT_double, "GET_double"];
+$insn_data{xlv_targoff} = [22, \&PUT_U32, "GET_U32"];
+$insn_data{xlv_targlen} = [23, \&PUT_U32, "GET_U32"];
+$insn_data{xlv_targ} = [24, \&PUT_objindex, "GET_objindex"];
+$insn_data{xlv_type} = [25, \&PUT_U8, "GET_U8"];
+$insn_data{xbm_useful} = [26, \&PUT_I32, "GET_I32"];
+$insn_data{xbm_previous} = [27, \&PUT_U16, "GET_U16"];
+$insn_data{xbm_rare} = [28, \&PUT_U8, "GET_U8"];
+$insn_data{xfm_lines} = [29, \&PUT_I32, "GET_I32"];
+$insn_data{xio_lines} = [30, \&PUT_I32, "GET_I32"];
+$insn_data{xio_page} = [31, \&PUT_I32, "GET_I32"];
+$insn_data{xio_page_len} = [32, \&PUT_I32, "GET_I32"];
+$insn_data{xio_lines_left} = [33, \&PUT_I32, "GET_I32"];
+$insn_data{xio_top_name} = [34, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{xio_top_gv} = [36, \&PUT_objindex, "GET_objindex"];
+$insn_data{xio_fmt_name} = [37, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{xio_fmt_gv} = [38, \&PUT_objindex, "GET_objindex"];
+$insn_data{xio_bottom_name} = [39, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{xio_bottom_gv} = [40, \&PUT_objindex, "GET_objindex"];
+$insn_data{xio_subprocess} = [41, \&PUT_U16, "GET_U16"];
+$insn_data{xio_type} = [42, \&PUT_U8, "GET_U8"];
+$insn_data{xio_flags} = [43, \&PUT_U8, "GET_U8"];
+$insn_data{xcv_stash} = [44, \&PUT_objindex, "GET_objindex"];
+$insn_data{xcv_start} = [45, \&PUT_objindex, "GET_objindex"];
+$insn_data{xcv_root} = [46, \&PUT_objindex, "GET_objindex"];
+$insn_data{xcv_gv} = [47, \&PUT_objindex, "GET_objindex"];
+$insn_data{xcv_filegv} = [48, \&PUT_objindex, "GET_objindex"];
+$insn_data{xcv_depth} = [49, \&PUT_I32, "GET_I32"];
+$insn_data{xcv_padlist} = [50, \&PUT_objindex, "GET_objindex"];
+$insn_data{xcv_outside} = [51, \&PUT_objindex, "GET_objindex"];
+$insn_data{xcv_flags} = [52, \&PUT_U8, "GET_U8"];
+$insn_data{av_extend} = [53, \&PUT_I32, "GET_I32"];
+$insn_data{av_push} = [54, \&PUT_objindex, "GET_objindex"];
+$insn_data{xav_fill} = [55, \&PUT_I32, "GET_I32"];
+$insn_data{xav_max} = [56, \&PUT_I32, "GET_I32"];
+$insn_data{xav_flags} = [57, \&PUT_U8, "GET_U8"];
+$insn_data{xhv_riter} = [58, \&PUT_I32, "GET_I32"];
+$insn_data{xhv_name} = [59, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{hv_store} = [60, \&PUT_objindex, "GET_objindex"];
+$insn_data{sv_magic} = [61, \&PUT_U8, "GET_U8"];
+$insn_data{mg_obj} = [62, \&PUT_objindex, "GET_objindex"];
+$insn_data{mg_private} = [63, \&PUT_U16, "GET_U16"];
+$insn_data{mg_flags} = [64, \&PUT_U8, "GET_U8"];
+$insn_data{mg_pv} = [65, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{xmg_stash} = [66, \&PUT_objindex, "GET_objindex"];
+$insn_data{gv_fetchpv} = [67, \&PUT_strconst, "GET_strconst"];
+$insn_data{gv_stashpv} = [68, \&PUT_strconst, "GET_strconst"];
+$insn_data{gp_sv} = [69, \&PUT_objindex, "GET_objindex"];
+$insn_data{gp_refcnt} = [70, \&PUT_U32, "GET_U32"];
+$insn_data{gp_refcnt_add} = [71, \&PUT_I32, "GET_I32"];
+$insn_data{gp_av} = [72, \&PUT_objindex, "GET_objindex"];
+$insn_data{gp_hv} = [73, \&PUT_objindex, "GET_objindex"];
+$insn_data{gp_cv} = [74, \&PUT_objindex, "GET_objindex"];
+$insn_data{gp_filegv} = [75, \&PUT_objindex, "GET_objindex"];
+$insn_data{gp_io} = [76, \&PUT_objindex, "GET_objindex"];
+$insn_data{gp_form} = [77, \&PUT_objindex, "GET_objindex"];
+$insn_data{gp_cvgen} = [78, \&PUT_U32, "GET_U32"];
+$insn_data{gp_line} = [79, \&PUT_U16, "GET_U16"];
+$insn_data{gp_share} = [80, \&PUT_objindex, "GET_objindex"];
+$insn_data{xgv_flags} = [81, \&PUT_U8, "GET_U8"];
+$insn_data{op_next} = [82, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_sibling} = [83, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_ppaddr} = [84, \&PUT_strconst, "GET_strconst"];
+$insn_data{op_targ} = [85, \&PUT_U32, "GET_U32"];
+$insn_data{op_type} = [86, \&PUT_U16, "GET_U16"];
+$insn_data{op_seq} = [87, \&PUT_U16, "GET_U16"];
+$insn_data{op_flags} = [88, \&PUT_U8, "GET_U8"];
+$insn_data{op_private} = [89, \&PUT_U8, "GET_U8"];
+$insn_data{op_first} = [90, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_last} = [91, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_other} = [92, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_true} = [93, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_false} = [94, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_children} = [95, \&PUT_U32, "GET_U32"];
+$insn_data{op_pmreplroot} = [96, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_pmreplrootgv} = [97, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_pmreplstart} = [98, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_pmnext} = [99, \&PUT_objindex, "GET_objindex"];
+$insn_data{pregcomp} = [100, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{op_pmflags} = [101, \&PUT_U16, "GET_U16"];
+$insn_data{op_pmpermflags} = [102, \&PUT_U16, "GET_U16"];
+$insn_data{op_sv} = [103, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_gv} = [104, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_pv} = [105, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{op_pv_tr} = [106, \&PUT_op_tr_array, "GET_op_tr_array"];
+$insn_data{op_redoop} = [107, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_nextop} = [108, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_lastop} = [109, \&PUT_objindex, "GET_objindex"];
+$insn_data{cop_label} = [110, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{cop_stash} = [111, \&PUT_objindex, "GET_objindex"];
+$insn_data{cop_filegv} = [112, \&PUT_objindex, "GET_objindex"];
+$insn_data{cop_seq} = [113, \&PUT_U32, "GET_U32"];
+$insn_data{cop_arybase} = [114, \&PUT_I32, "GET_I32"];
+$insn_data{cop_line} = [115, \&PUT_U16, "GET_U16"];
+$insn_data{main_start} = [116, \&PUT_objindex, "GET_objindex"];
+$insn_data{main_root} = [117, \&PUT_objindex, "GET_objindex"];
+$insn_data{curpad} = [118, \&PUT_objindex, "GET_objindex"];
+
+my ($insn_name, $insn_data);
+while (($insn_name, $insn_data) = each %insn_data) {
+    $insn_name[$insn_data->[0]] = $insn_name;
+}
+# Fill in any gaps
+@insn_name = map($_ || "unused", @insn_name);
+
+1;
diff --git a/ext/B/B/Assembler.pm b/ext/B/B/Assembler.pm
new file mode 100644
index 0000000000..0729b90f28
--- /dev/null
+++ b/ext/B/B/Assembler.pm
@@ -0,0 +1,207 @@
+#      Assembler.pm
+#
+#      Copyright (c) 1996 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.
+package B::Assembler;
+use Exporter;
+use B qw(ppname);
+use B::Asmdata qw(%insn_data @insn_name);
+
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(assemble_fh assemble_insn strip_comments
+		parse_statement uncstring);
+
+use strict;
+my %opnumber;
+my ($i, $opname);
+for ($i = 0; defined($opname = ppname($i)); $i++) {
+    $opnumber{$opname} = $i;
+}
+
+my ($linenum, $errors);
+
+sub error {
+    my $str = shift;
+    warn "$linenum: $str\n";
+    $errors++;
+}
+
+my $debug = 0;
+sub debug { $debug = shift }
+
+#
+# First define all the data conversion subs to which Asmdata will refer
+#
+
+sub B::Asmdata::PUT_U8 {
+    my $arg = shift;
+    my $c = uncstring($arg);
+    if (defined($c)) {
+	if (length($c) != 1) {
+	    error "argument for U8 is too long: $c";
+	    $c = substr($c, 0, 1);
+	}
+    } else {
+	$c = chr($arg);
+    }
+    return $c;
+}
+
+sub B::Asmdata::PUT_U16 { pack("n", $_[0]) }
+sub B::Asmdata::PUT_U32 { pack("N", $_[0]) }
+sub B::Asmdata::PUT_I32 { pack("N", $_[0]) }
+sub B::Asmdata::PUT_objindex { pack("N", $_[0]) } # could allow names here
+
+sub B::Asmdata::PUT_strconst {
+    my $arg = shift;
+    $arg = uncstring($arg);
+    if (!defined($arg)) {
+	error "bad string constant: $arg";
+	return "";
+    }
+    if ($arg =~ s/\0//g) {
+	error "string constant argument contains NUL: $arg";
+    }
+    return $arg . "\0";
+}
+
+sub B::Asmdata::PUT_pvcontents {
+    my $arg = shift;
+    error "extraneous argument: $arg" if defined $arg;
+    return "";
+}
+sub B::Asmdata::PUT_PV {
+    my $arg = shift;
+    $arg = uncstring($arg);
+    error "bad string argument: $arg" unless defined($arg);
+    return pack("N", length($arg)) . $arg;
+}
+sub B::Asmdata::PUT_comment {
+    my $arg = shift;
+    $arg = uncstring($arg);
+    error "bad string argument: $arg" unless defined($arg);
+    if ($arg =~ s/\n//g) {
+	error "comment argument contains linefeed: $arg";
+    }
+    return $arg . "\n";
+}
+sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) }
+sub B::Asmdata::PUT_none {
+    my $arg = shift;
+    error "extraneous argument: $arg" if defined $arg;
+    return "";
+}
+sub B::Asmdata::PUT_op_tr_array {
+    my $arg = shift;
+    my @ary = split(/\s*,\s*/, $arg);
+    if (@ary != 256) {
+	error "wrong number of arguments to op_tr_array";
+	@ary = (0) x 256;
+    }
+    return pack("n256", @ary);
+}
+# XXX Check this works
+sub B::Asmdata::PUT_IV64 {
+    my $arg = shift;
+    return pack("NN", $arg >> 32, $arg & 0xffffffff);
+}
+
+my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
+	     b => "\b", f => "\f", v => "\013");
+
+sub uncstring {
+    my $s = shift;
+    $s =~ s/^"// and $s =~ s/"$// or return undef;
+    $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg;
+    return $s;
+}
+
+sub strip_comments {
+    my $stmt = shift;
+    # Comments only allowed in instructions which don't take string arguments
+    $stmt =~ s{
+	(?sx)	# Snazzy extended regexp coming up. Also, treat
+		# string as a single line so .* eats \n characters.
+	^\s*	# Ignore leading whitespace
+	(
+	  [^"]*	# A double quote '"' indicates a string argument. If we
+		# find a double quote, the match fails and we strip nothing.
+	)
+	\s*\#	# Any amount of whitespace plus the comment marker...
+	.*$	# ...which carries on to end-of-string.
+    }{$1};	# Keep only the instruction and optional argument.
+    return $stmt;
+}
+
+sub parse_statement {
+    my $stmt = shift;
+    my ($insn, $arg) = $stmt =~ m{
+	(?sx)
+	^\s*	# allow (but ignore) leading whitespace
+	(.*?)	# Instruction continues up until...
+	(?:	# ...an optional whitespace+argument group
+	    \s+		# first whitespace.
+	    (.*)	# The argument is all the rest (newlines included).
+	)?$	# anchor at end-of-line
+    };	
+    if (defined($arg)) {
+	if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {
+	    $arg = hex($arg);
+	} elsif ($arg =~ s/^0(?=[0-7]+$)//) {
+	    $arg = oct($arg);
+	} elsif ($arg =~ /^pp_/) {
+	    $arg =~ s/\s*$//; # strip trailing whitespace
+	    my $opnum = $opnumber{$arg};
+	    if (defined($opnum)) {
+		$arg = $opnum;
+	    } else {
+		error qq(No such op type "$arg");
+		$arg = 0;
+	    }
+	}
+    }
+    return ($insn, $arg);
+}
+
+sub assemble_insn {
+    my ($insn, $arg) = @_;
+    my $data = $insn_data{$insn};
+    if (defined($data)) {
+	my ($bytecode, $putsub) = @{$data}[0, 1];
+	my $argcode = &$putsub($arg);
+	return chr($bytecode).$argcode;
+    } else {
+	error qq(no such instruction "$insn");
+	return "";
+    }
+}
+
+sub assemble_fh {
+    my ($fh, $out) = @_;
+    my ($line, $insn, $arg);
+    $linenum = 0;
+    $errors = 0;
+    while ($line = <$fh>) {
+	$linenum++;
+	chomp $line;
+	if ($debug) {
+	    my $quotedline = $line;
+	    $quotedline =~ s/\\/\\\\/g;
+	    $quotedline =~ s/"/\\"/g;
+	    &$out(assemble_insn("comment", qq("$quotedline")));
+	}
+	$line = strip_comments($line) or next;
+	($insn, $arg) = parse_statement($line);
+	&$out(assemble_insn($insn, $arg));
+	if ($debug) {
+	    &$out(assemble_insn("nop", undef));
+	}
+    }
+    if ($errors) {
+	die "Assembly failed with $errors error(s)\n";
+    }
+}
+
+1;
diff --git a/ext/B/B/Bblock.pm b/ext/B/B/Bblock.pm
new file mode 100644
index 0000000000..125c8a3c65
--- /dev/null
+++ b/ext/B/B/Bblock.pm
@@ -0,0 +1,142 @@
+package B::Bblock;
+use Exporter ();
+@ISA = "Exporter";
+@EXPORT_OK = qw(find_leaders);
+
+use B qw(peekop walkoptree walkoptree_exec
+	 main_root main_start svref_2object);
+use B::Terse;
+use strict;
+
+my $bblock;
+my @bblock_ends;
+
+sub mark_leader {
+    my $op = shift;
+    if ($$op) {
+	$bblock->{$$op} = $op;
+    }
+}
+
+sub find_leaders {
+    my ($root, $start) = @_;
+    $bblock = {};
+    mark_leader($start);
+    walkoptree($root, "mark_if_leader");
+    return $bblock;
+}
+
+# Debugging
+sub walk_bblocks {
+    my ($root, $start) = @_;
+    my ($op, $lastop, $leader, $bb);
+    $bblock = {};
+    mark_leader($start);
+    walkoptree($root, "mark_if_leader");
+    my @leaders = values %$bblock;
+    while ($leader = shift @leaders) {
+	$lastop = $leader;
+	$op = $leader->next;
+	while ($$op && !exists($bblock->{$$op})) {
+	    $bblock->{$$op} = $leader;
+	    $lastop = $op;
+	    $op = $op->next;
+	}
+	push(@bblock_ends, [$leader, $lastop]);
+    }
+    foreach $bb (@bblock_ends) {
+	($leader, $lastop) = @$bb;
+	printf "%s .. %s\n", peekop($leader), peekop($lastop);
+	for ($op = $leader; $$op != $$lastop; $op = $op->next) {
+	    printf "    %s\n", peekop($op);
+	}
+	printf "    %s\n", peekop($lastop);
+    }
+    print "-------\n";
+    walkoptree_exec($start, "terse");
+}
+
+sub walk_bblocks_obj {
+    my $cvref = shift;
+    my $cv = svref_2object($cvref);
+    walk_bblocks($cv->ROOT, $cv->START);
+}
+
+sub B::OP::mark_if_leader {}
+
+sub B::COP::mark_if_leader {
+    my $op = shift;
+    if ($op->label) {
+	mark_leader($op);
+    }
+}
+
+sub B::LOOP::mark_if_leader {
+    my $op = shift;
+    mark_leader($op->next);
+    mark_leader($op->nextop);
+    mark_leader($op->redoop);
+    mark_leader($op->lastop->next);
+}
+
+sub B::LOGOP::mark_if_leader {
+    my $op = shift;
+    my $ppaddr = $op->ppaddr;
+    mark_leader($op->next);
+    if ($ppaddr eq "pp_entertry") {
+	mark_leader($op->other->next);
+    } else {
+	mark_leader($op->other);
+    }
+}
+
+sub B::CONDOP::mark_if_leader {
+    my $op = shift;
+    mark_leader($op->next);
+    mark_leader($op->true);
+    mark_leader($op->false);
+}
+
+sub B::PMOP::mark_if_leader {
+    my $op = shift;
+    if ($op->ppaddr ne "pp_pushre") {
+	my $replroot = $op->pmreplroot;
+	if ($$replroot) {
+	    mark_leader($replroot);
+	    mark_leader($op->next);
+	    mark_leader($op->pmreplstart);
+	}
+    }
+}
+
+# PMOP stuff omitted
+
+sub compile {
+    my @options = @_;
+    if (@options) {
+	return sub {
+	    my $objname;
+	    foreach $objname (@options) {
+		$objname = "main::$objname" unless $objname =~ /::/;
+		eval "walk_bblocks_obj(\\&$objname)";
+		die "walk_bblocks_obj(\\&$objname) failed: $@" if $@;
+	    }
+	}
+    } else {
+	return sub { walk_bblocks(main_root, main_start) };
+    }
+}
+
+# Basic block leaders:
+#     Any COP (pp_nextstate) with a non-NULL label
+#     [The op after a pp_enter] Omit
+#     [The op after a pp_entersub. Don't count this one.]
+#     The ops pointed at by nextop, redoop and lastop->op_next of a LOOP
+#     The ops pointed at by op_next and op_other of a LOGOP, except
+#     for pp_entertry which has op_next and op_other->op_next
+#     The ops pointed at by op_true and op_false of a CONDOP
+#     The op pointed at by op_pmreplstart of a PMOP
+#     The op pointed at by op_other->op_pmreplstart of pp_substcont?
+#     [The op after a pp_return] Omit
+
+1;
diff --git a/ext/B/B/Bytecode.pm b/ext/B/B/Bytecode.pm
new file mode 100644
index 0000000000..447bd3700a
--- /dev/null
+++ b/ext/B/B/Bytecode.pm
@@ -0,0 +1,778 @@
+#      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.
+#
+package B::Bytecode;
+use strict;
+use Carp;
+use IO::File;
+
+use B qw(minus_c main_cv main_root main_start comppadlist
+	 class peekop walkoptree svref_2object cstring walksymtable);
+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 () { 0x04040000 }
+
+# Following is SVf_IOK|SVp_OK
+# XXX Shouldn't be hardwired
+sub IOK () { 0x01010000 }
+
+my ($verbose, $module_only, $no_assemble, $debug_bc, $debug_cv);
+my $assembler_pid;
+
+# 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;
+    }
+}
+
+sub stsv {
+    my $ix = shift;
+    print "stsv $ix\n";
+    $svix = $ix;
+}
+
+sub set_svix {
+    $svix = shift;
+}
+
+sub ldop {
+    my $ix = shift;
+    if ($ix != $opix) {
+	print "ldop $ix\n";
+	$opix = $ix;
+    }
+}
+
+sub stop {
+    my $ix = shift;
+    print "stop $ix\n";
+    $opix = $ix;
+}
+
+sub set_opix {
+    $opix = shift;
+}
+
+sub pvstring {
+    my $str = shift;
+    if (defined($str)) {
+	return cstring($str . "\0");
+    } else {
+	return '""';
+    }
+}
+
+sub saved { $saved{${$_[0]}} }
+sub mark_saved { $saved{${$_[0]}} = 1 }
+sub unmark_saved { $saved{${$_[0]}} = 0 }
+
+sub debug { $debug_bc = shift }
+
+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::SV::newix {
+    my ($sv, $ix) = @_;
+    printf "newsv %d\t# %s\n", $sv->FLAGS & 0xf, class($sv);
+    stsv($ix);    
+}
+
+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::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::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::OP::newix {
+    my ($op, $ix) = @_;
+    my $class = class($op);
+    my $typenum = $optype_enum{$class};
+    croak "OP::newix: can't understand class $class" unless defined($typenum);
+    print "newop $typenum\t# $class\n";
+    stop($ix);
+}
+
+sub B::OP::walkoptree_debug {
+    my $op = shift;
+    warn(sprintf("walkoptree: %s\n", peekop($op)));
+}
+
+sub B::OP::bytecode {
+    my $op = shift;
+    my $next = $op->next;
+    my $nextix;
+    my $sibix = $op->sibling->objix;
+    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", $op->ppaddr, $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::UNOP::bytecode {
+    my $op = shift;
+    my $firstix = $op->first->objix;
+    $op->B::OP::bytecode;
+    if (($op->type || !$compress_nullops) && !$strip_syntree) {
+	print "op_first $firstix\n";
+    }
+}
+
+sub B::LOGOP::bytecode {
+    my $op = shift;
+    my $otherix = $op->other->objix;
+    $op->B::UNOP::bytecode;
+    print "op_other $otherix\n";
+}
+
+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;
+}
+
+sub B::GVOP::bytecode {
+    my $op = shift;
+    my $gv = $op->gv;
+    my $gvix = $gv->objix;
+    $op->B::OP::bytecode;
+    print "op_gv $gvix\n";
+    $gv->bytecode;
+}
+
+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->ppaddr eq "pp_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::BINOP::bytecode {
+    my $op = shift;
+    my $lastix = $op->last->objix;
+    $op->B::UNOP::bytecode;
+    if (($op->type || !$compress_nullops) && !$strip_syntree) {
+	print "op_last $lastix\n";
+    }
+}
+
+sub B::CONDOP::bytecode {
+    my $op = shift;
+    my $trueix = $op->true->objix;
+    my $falseix = $op->false->objix;
+    $op->B::UNOP::bytecode;
+    print "op_true $trueix\nop_false $falseix\n";
+}
+
+sub B::LISTOP::bytecode {
+    my $op = shift;
+    my $children = $op->children;
+    $op->B::BINOP::bytecode;
+    if (($op->type || !$compress_nullops) && !$strip_syntree) {
+	print "op_children $children\n";
+    }
+}
+
+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::COP::bytecode {
+    my $op = shift;
+    my $stash = $op->stash;
+    my $stashix = $stash->objix;
+    my $filegv = $op->filegv;
+    my $filegvix = $filegv->objix;
+    my $line = $op->line;
+    if ($debug_bc) {
+	printf "# line %s:%d\n", $filegv->SV->PV, $line;
+    }
+    $op->B::OP::bytecode;
+    printf <<"EOT", pvstring($op->label), $op->cop_seq, $op->arybase;
+newpv %s
+cop_label
+cop_stash $stashix
+cop_seq %d
+cop_filegv $filegvix
+cop_arybase %d
+cop_line $line
+EOT
+    $filegv->bytecode;
+    $stash->bytecode;
+}
+
+sub B::PMOP::bytecode {
+    my $op = shift;
+    my $replroot = $op->pmreplroot;
+    my $replrootix = $replroot->objix;
+    my $replstartix = $op->pmreplstart->objix;
+    my $ppaddr = $op->ppaddr;
+    # 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 ($ppaddr eq "pp_pushre") {
+	    $replroot->bytecode;
+	} else {
+	    walkoptree($replroot, "bytecode");
+	}
+    }
+    $op->B::LISTOP::bytecode;
+    if ($ppaddr eq "pp_pushre") {
+	printf "op_pmreplrootgv $replrootix\n";
+    } else {
+	print "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n";
+    }
+    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);
+}
+
+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::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";
+}
+
+sub B::NV::bytecode {
+    my $sv = shift;
+    return if saved($sv);
+    $sv->B::SV::bytecode;
+    printf "xnv %s\n", $sv->NVX;
+}
+
+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::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::PVNV::bytecode {
+    my ($sv, $flag) = @_;
+    # 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", $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::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);
+    }
+}
+
+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
+}
+
+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::GV::bytecode {
+    my $gv = shift;
+    return if saved($gv);
+    my $ix = $gv->objix;
+    mark_saved($gv);
+    my $gvname = $gv->NAME;
+    my $name = cstring($gv->STASH->NAME . "::" . $gvname);
+    my $egv = $gv->EGV;
+    my $egvix = $egv->objix;
+    ldsv($ix);
+    printf <<"EOT", $gv->FLAGS, $gv->GvFLAGS, $gv->LINE;
+sv_flags 0x%x
+xgv_flags 0x%x
+gp_line %d
+EOT
+    my $refcnt = $gv->REFCNT;
+    printf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1;
+    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 FILEGV FORM IO);
+	    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;
+	    }
+	}
+    }
+}
+
+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::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 "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";
+	}
+    } else {
+	if ($max > -1) {
+	    print "av_extend $max\n";
+	}
+    }
+}
+
+sub B::CV::bytecode {
+    my $cv = shift;
+    return if saved($cv);
+    my $ix = $cv->objix;
+    $cv->B::PVMG::bytecode;
+    my $i;
+    my @subfield_names = qw(ROOT START STASH GV FILEGV 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->FLAGS;
+    # 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;
+    }
+}
+
+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::SPECIAL::bytecode {
+    # nothing extra needs doing
+}
+
+sub bytecompile_object {
+    my $sv;
+    foreach $sv (@_) {
+	svref_2object($sv)->bytecode;
+    }
+}
+
+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);
+	}
+	$gv->bytecode;
+    }
+}
+
+sub bytecompile_main {
+    my $curpad = (comppadlist->ARRAY)[1];
+    my $curpadix = $curpad->objix;
+    $curpad->bytecode;
+    walkoptree(main_root, "bytecode");
+    warn "done main program, now walking symbol table\n" if $debug_bc;
+    my ($pack, %exclude);
+    foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS strict vars
+		      FileHandle Exporter Carp UNIVERSAL IO Fcntl Symbol
+		      SelectSaver blib Cwd))
+    {
+	$exclude{$pack."::"} = 1;
+    }
+    no strict qw(vars refs);
+    walksymtable(\%{"main::"}, "bytecodecv", sub {
+	warn "considering $_[0]\n" if $debug_bc;
+	return !defined($exclude{$_[0]});
+    });
+    if (!$module_only) {
+	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;
+	} else {
+	    unshift @options, $option;
+	    last 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 "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;
+		}
+	    }
+	} elsif ($opt eq "v") {
+	    $verbose = 1;
+	} elsif ($opt eq "m") {
+	    $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;
+	    }
+	}
+    }
+    if (@options) {
+	return sub {
+	    my $objname;
+	    my $newfh; 
+	    $newfh = prepare_assemble() unless $no_assemble;
+	    foreach $objname (@options) {
+		eval "bytecompile_object(\\$objname)";
+	    }
+	    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;
+	}
+    }
+}
+
+1;
diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm
new file mode 100644
index 0000000000..4158bc40ac
--- /dev/null
+++ b/ext/B/B/C.pm
@@ -0,0 +1,1201 @@
+#      C.pm
+#
+#      Copyright (c) 1996, 1997 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.
+#
+package B::C;
+use Exporter ();
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(output_all output_boilerplate output_main
+		init_sections set_callback save_unused_subs objsym);
+
+use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop
+	 class cstring cchar svref_2object compile_stats comppadlist hash
+	 threadsv_names);
+use B::Asmdata qw(@specialsv_name);
+
+use FileHandle;
+use Carp;
+use strict;
+
+my $hv_index = 0;
+my $gv_index = 0;
+my $re_index = 0;
+my $pv_index = 0;
+my $anonsub_index = 0;
+
+my %symtable;
+my $warn_undefined_syms;
+my $verbose;
+my @unused_sub_packages;
+my $nullop_count;
+my $pv_copy_on_grow;
+my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
+
+my @threadsv_names;
+BEGIN {
+    @threadsv_names = threadsv_names();
+}
+
+# Code sections
+my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect, $cvopsect,
+    $gvopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
+    $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
+    $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
+    $xrvsect, $xpvbmsect, $xpviosect);
+
+sub walk_and_save_optree;
+my $saveoptree_callback = \&walk_and_save_optree;
+sub set_callback { $saveoptree_callback = shift }
+sub saveoptree { &$saveoptree_callback(@_) }
+
+sub walk_and_save_optree {
+    my ($name, $root, $start) = @_;
+    walkoptree($root, "save");
+    return objsym($start);
+}
+
+# Current workaround/fix for op_free() trying to free statically
+# defined OPs is to set op_seq = -1 and check for that in op_free().
+# Instead of hardwiring -1 in place of $op->seq, we use $op_seq
+# so that it can be changed back easily if necessary. In fact, to
+# stop compilers from moaning about a U16 being initialised with an
+# uncast -1 (the printf format is %d so we can't tweak it), we have
+# to "know" that op_seq is a U16 and use 65535. Ugh.
+my $op_seq = 65535;
+
+sub AVf_REAL () { 1 }
+
+# XXX This shouldn't really be hardcoded here but it saves
+# looking up the name of every BASEOP in B::OP
+sub OP_THREADSV () { 345 }
+
+sub savesym {
+    my ($obj, $value) = @_;
+    my $sym = sprintf("s\\_%x", $$obj);
+    $symtable{$sym} = $value;
+}
+
+sub objsym {
+    my $obj = shift;
+    return $symtable{sprintf("s\\_%x", $$obj)};
+}
+
+sub getsym {
+    my $sym = shift;
+    my $value;
+
+    return 0 if $sym eq "sym_0";	# special case
+    $value = $symtable{$sym};
+    if (defined($value)) {
+	return $value;
+    } else {
+	warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
+	return "UNUSED";
+    }
+}
+
+sub savepv {
+    my $pv = shift;
+    my $pvsym = 0;
+    my $pvmax = 0;
+    if ($pv_copy_on_grow) {
+	my $cstring = cstring($pv);
+	if ($cstring ne "0") { # sic
+	    $pvsym = sprintf("pv%d", $pv_index++);
+	    $decl->add(sprintf("static char %s[] = %s;", $pvsym, $cstring));
+	}
+    } else {
+	$pvmax = length($pv) + 1;
+    }
+    return ($pvsym, $pvmax);
+}
+
+sub B::OP::save {
+    my ($op, $level) = @_;
+    my $type = $op->type;
+    $nullop_count++ unless $type;
+    if ($type == OP_THREADSV) {
+	# saves looking up ppaddr but it's a bit naughty to hard code this
+	$init->add(sprintf("(void)find_threadsv(%s);",
+			   cstring($threadsv_names[$op->targ])));
+    }
+    $opsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x",
+			 ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ,
+			 $type, $op_seq, $op->flags, $op->private));
+    savesym($op, sprintf("&op_list[%d]", $opsect->index));
+}
+
+sub B::FAKEOP::new {
+    my ($class, %objdata) = @_;
+    bless \%objdata, $class;
+}
+
+sub B::FAKEOP::save {
+    my ($op, $level) = @_;
+    $opsect->add(sprintf("%s, %s, %s, %u, %u, %u, 0x%x, 0x%x",
+			 $op->next, $op->sibling, $op->ppaddr, $op->targ,
+			 $op->type, $op_seq, $op->flags, $op->private));
+    return sprintf("&op_list[%d]", $opsect->index);
+}
+
+sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
+sub B::FAKEOP::type { $_[0]->{type} || 0}
+sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
+sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
+sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
+sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
+sub B::FAKEOP::private { $_[0]->{private} || 0 }
+
+sub B::UNOP::save {
+    my ($op, $level) = @_;
+    $unopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x",
+			   ${$op->next}, ${$op->sibling}, $op->ppaddr,
+			   $op->targ, $op->type, $op_seq, $op->flags,
+			   $op->private, ${$op->first}));
+    savesym($op, sprintf("(OP*)&unop_list[%d]", $unopsect->index));
+}
+
+sub B::BINOP::save {
+    my ($op, $level) = @_;
+    $binopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
+			    ${$op->next}, ${$op->sibling}, $op->ppaddr,
+			    $op->targ, $op->type, $op_seq, $op->flags,
+			    $op->private, ${$op->first}, ${$op->last}));
+    savesym($op, sprintf("(OP*)&binop_list[%d]", $binopsect->index));
+}
+
+sub B::LISTOP::save {
+    my ($op, $level) = @_;
+    $listopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u",
+			     ${$op->next}, ${$op->sibling}, $op->ppaddr,
+			     $op->targ, $op->type, $op_seq, $op->flags,
+			     $op->private, ${$op->first}, ${$op->last},
+			     $op->children));
+    savesym($op, sprintf("(OP*)&listop_list[%d]", $listopsect->index));
+}
+
+sub B::LOGOP::save {
+    my ($op, $level) = @_;
+    $logopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
+			    ${$op->next}, ${$op->sibling}, $op->ppaddr,
+			    $op->targ, $op->type, $op_seq, $op->flags,
+			    $op->private, ${$op->first}, ${$op->other}));
+    savesym($op, sprintf("(OP*)&logop_list[%d]", $logopsect->index));
+}
+
+sub B::CONDOP::save {
+    my ($op, $level) = @_;
+    $condopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, s\\_%x",
+			     ${$op->next}, ${$op->sibling}, $op->ppaddr,
+			     $op->targ, $op->type, $op_seq, $op->flags,
+			     $op->private, ${$op->first}, ${$op->true},
+			     ${$op->false}));
+    savesym($op, sprintf("(OP*)&condop_list[%d]", $condopsect->index));
+}
+
+sub B::LOOP::save {
+    my ($op, $level) = @_;
+    #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
+    #		 peekop($op->redoop), peekop($op->nextop),
+    #		 peekop($op->lastop)); # debug
+    $loopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, s\\_%x, s\\_%x, s\\_%x",
+			   ${$op->next}, ${$op->sibling}, $op->ppaddr,
+			   $op->targ, $op->type, $op_seq, $op->flags,
+			   $op->private, ${$op->first}, ${$op->last},
+			   $op->children, ${$op->redoop}, ${$op->nextop},
+			   ${$op->lastop}));
+    savesym($op, sprintf("(OP*)&loop_list[%d]", $loopsect->index));
+}
+
+sub B::PVOP::save {
+    my ($op, $level) = @_;
+    $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
+			   ${$op->next}, ${$op->sibling}, $op->ppaddr,
+			   $op->targ, $op->type, $op_seq, $op->flags,
+			   $op->private, cstring($op->pv)));
+    savesym($op, sprintf("(OP*)&pvop_list[%d]", $pvopsect->index));
+}
+
+sub B::SVOP::save {
+    my ($op, $level) = @_;
+    my $svsym = $op->sv->save;
+    $svopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
+			   ${$op->next}, ${$op->sibling}, $op->ppaddr,
+			   $op->targ, $op->type, $op_seq, $op->flags,
+			   $op->private, "(SV*)$svsym"));
+    savesym($op, sprintf("(OP*)&svop_list[%d]", $svopsect->index));
+}
+
+sub B::GVOP::save {
+    my ($op, $level) = @_;
+    my $gvsym = $op->gv->save;
+    $gvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, Nullgv",
+			   ${$op->next}, ${$op->sibling}, $op->ppaddr,
+			   $op->targ, $op->type, $op_seq, $op->flags,
+			   $op->private));
+    $init->add(sprintf("gvop_list[%d].op_gv = %s;", $gvopsect->index, $gvsym));
+    savesym($op, sprintf("(OP*)&gvop_list[%d]", $gvopsect->index));
+}
+
+sub B::COP::save {
+    my ($op, $level) = @_;
+    my $gvsym = $op->filegv->save;
+    my $stashsym = $op->stash->save;
+    warn sprintf("COP: line %d file %s\n", $op->line, $op->filegv->SV->PV)
+	if $debug_cops;
+    $copsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s, Nullhv, Nullgv, %u, %d, %u",
+			  ${$op->next}, ${$op->sibling}, $op->ppaddr,
+			  $op->targ, $op->type, $op_seq, $op->flags,
+			  $op->private, cstring($op->label), $op->cop_seq,
+			  $op->arybase, $op->line));
+    my $copix = $copsect->index;
+    $init->add(sprintf("cop_list[%d].cop_filegv = %s;", $copix, $gvsym),
+	       sprintf("cop_list[%d].cop_stash = %s;", $copix, $stashsym));
+    savesym($op, "(OP*)&cop_list[$copix]");
+}
+
+sub B::PMOP::save {
+    my ($op, $level) = @_;
+    my $replroot = $op->pmreplroot;
+    my $replstart = $op->pmreplstart;
+    my $replrootfield = sprintf("s\\_%x", $$replroot);
+    my $replstartfield = sprintf("s\\_%x", $$replstart);
+    my $gvsym;
+    my $ppaddr = $op->ppaddr;
+    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 ($ppaddr eq "pp_pushre") {
+	    $gvsym = $replroot->save;
+#	    warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
+	    $replrootfield = 0;
+	} else {
+	    $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
+	}
+    }
+    # pmnext handling is broken in perl itself, I think. Bad op_pmnext
+    # fields aren't noticed in perl's runtime (unless you try reset) but we
+    # segfault when trying to dereference it to find op->op_pmnext->op_type
+    $pmopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, %s, %s, 0, 0, 0x%x, 0x%x",
+			   ${$op->next}, ${$op->sibling}, $ppaddr, $op->targ,
+			   $op->type, $op_seq, $op->flags, $op->private,
+			   ${$op->first}, ${$op->last}, $op->children,
+			   $replrootfield, $replstartfield,
+			   $op->pmflags, $op->pmpermflags,));
+    my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
+    my $re = $op->precomp;
+    if (defined($re)) {
+	my $resym = sprintf("re%d", $re_index++);
+	$decl->add(sprintf("static char *$resym = %s;", cstring($re)));
+	$init->add(sprintf("$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);",
+			   length($re)));
+    }
+    if ($gvsym) {
+	$init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
+    }
+    savesym($op, sprintf("(OP*)&pmop_list[%d]", $pmopsect->index));
+}
+
+sub B::SPECIAL::save {
+    my ($sv) = @_;
+    # special case: $$sv is not the address but an index into specialsv_list
+#   warn "SPECIAL::save specialsv $$sv\n"; # debug
+    my $sym = $specialsv_name[$$sv];
+    if (!defined($sym)) {
+	confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
+    }
+    return $sym;
+}
+
+sub B::OBJECT::save {}
+
+sub B::NULL::save {
+    my ($sv) = @_;
+    my $sym = objsym($sv);
+    return $sym if defined $sym;
+#   warn "Saving SVt_NULL SV\n"; # debug
+    # debug
+    #if ($$sv == 0) {
+    #	warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
+    #}
+    $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT + 1, $sv->FLAGS));
+    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub B::IV::save {
+    my ($sv) = @_;
+    my $sym = objsym($sv);
+    return $sym if defined $sym;
+    $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
+    $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
+			 $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
+    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub B::NV::save {
+    my ($sv) = @_;
+    my $sym = objsym($sv);
+    return $sym if defined $sym;
+    $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $sv->NVX));
+    $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
+			 $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
+    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub B::PVLV::save {
+    my ($sv) = @_;
+    my $sym = objsym($sv);
+    return $sym if defined $sym;
+    my $pv = $sv->PV;
+    my $len = length($pv);
+    my ($pvsym, $pvmax) = savepv($pv);
+    my ($lvtarg, $lvtarg_sym);
+    $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
+			    $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX, 
+			    $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
+    $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
+			 $xpvlvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
+    if (!$pv_copy_on_grow) {
+	$init->add(sprintf("xpvlv_list[%d].xpv_pv = savepvn(%s, %u);",
+			   $xpvlvsect->index, cstring($pv), $len));
+    }
+    $sv->save_magic;
+    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub B::PVIV::save {
+    my ($sv) = @_;
+    my $sym = objsym($sv);
+    return $sym if defined $sym;
+    my $pv = $sv->PV;
+    my $len = length($pv);
+    my ($pvsym, $pvmax) = savepv($pv);
+    $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX));
+    $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
+			 $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
+    if (!$pv_copy_on_grow) {
+	$init->add(sprintf("xpviv_list[%d].xpv_pv = savepvn(%s, %u);",
+			   $xpvivsect->index, cstring($pv), $len));
+    }
+    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub B::PVNV::save {
+    my ($sv) = @_;
+    my $sym = objsym($sv);
+    return $sym if defined $sym;
+    my $pv = $sv->PV;
+    my $len = length($pv);
+    my ($pvsym, $pvmax) = savepv($pv);
+    $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
+			    $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
+    $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
+			 $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
+    if (!$pv_copy_on_grow) {
+	$init->add(sprintf("xpvnv_list[%d].xpv_pv = savepvn(%s,%u);",
+			   $xpvnvsect->index, cstring($pv), $len));
+    }
+    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub B::BM::save {
+    my ($sv) = @_;
+    my $sym = objsym($sv);
+    return $sym if defined $sym;
+    my $pv = $sv->PV . "\0" . $sv->TABLE;
+    my $len = length($pv);
+    $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
+			    $len, $len + 258, $sv->IVX, $sv->NVX,
+			    $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
+    $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
+			 $xpvbmsect->index, $sv->REFCNT + 1, $sv->FLAGS));
+    $sv->save_magic;
+    $init->add(sprintf("xpvbm_list[%d].xpv_pv = savepvn(%s, %u);",
+		       $xpvbmsect->index, cstring($pv), $len),
+	       sprintf("xpvbm_list[%d].xpv_cur = %u;",
+		       $xpvbmsect->index, $len - 257));
+    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub B::PV::save {
+    my ($sv) = @_;
+    my $sym = objsym($sv);
+    return $sym if defined $sym;
+    my $pv = $sv->PV;
+    my $len = length($pv);
+    my ($pvsym, $pvmax) = savepv($pv);
+    $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax));
+    $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
+			 $xpvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
+    if (!$pv_copy_on_grow) {
+	$init->add(sprintf("xpv_list[%d].xpv_pv = savepvn(%s, %u);",
+			   $xpvsect->index, cstring($pv), $len));
+    }
+    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub B::PVMG::save {
+    my ($sv) = @_;
+    my $sym = objsym($sv);
+    return $sym if defined $sym;
+    my $pv = $sv->PV;
+    my $len = length($pv);
+    my ($pvsym, $pvmax) = savepv($pv);
+    $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
+			    $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
+    $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
+			 $xpvmgsect->index, $sv->REFCNT + 1, $sv->FLAGS));
+    if (!$pv_copy_on_grow) {
+	$init->add(sprintf("xpvmg_list[%d].xpv_pv = savepvn(%s, %u);",
+			   $xpvmgsect->index, cstring($pv), $len));
+    }
+    $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+    $sv->save_magic;
+    return $sym;
+}
+
+sub B::PVMG::save_magic {
+    my ($sv) = @_;
+    #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
+    my $stash = $sv->SvSTASH;
+    if ($$stash) {
+	warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
+	    if $debug_mg;
+	# XXX Hope stash is already going to be saved.
+	$init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
+    }
+    my @mgchain = $sv->MAGIC;
+    my ($mg, $type, $obj, $ptr);
+    foreach $mg (@mgchain) {
+	$type = $mg->TYPE;
+	$obj = $mg->OBJ;
+	$ptr = $mg->PTR;
+	my $len = defined($ptr) ? length($ptr) : 0;
+	if ($debug_mg) {
+	    warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
+			 class($sv), $$sv, class($obj), $$obj,
+			 cchar($type), cstring($ptr));
+	}
+	$init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
+			   $$sv, $$obj, cchar($type),cstring($ptr),$len));
+    }
+}
+
+sub B::RV::save {
+    my ($sv) = @_;
+    my $sym = objsym($sv);
+    return $sym if defined $sym;
+    $xrvsect->add($sv->RV->save);
+    $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
+			 $xrvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
+    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub try_autoload {
+    my ($cvstashname, $cvname) = @_;
+    warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
+    # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
+    # use should be handled by the class itself.
+    no strict 'refs';
+    my $isa = \@{"$cvstashname\::ISA"};
+    if (grep($_ eq "AutoLoader", @$isa)) {
+	warn "Forcing immediate load of sub derived from AutoLoader\n";
+	# Tweaked version of AutoLoader::AUTOLOAD
+	my $dir = $cvstashname;
+	$dir =~ s(::)(/)g;
+	eval { require "auto/$dir/$cvname.al" };
+	if ($@) {
+	    warn qq(failed require "auto/$dir/$cvname.al": $@\n);
+	    return 0;
+	} else {
+	    return 1;
+	}
+    }
+}
+
+sub B::CV::save {
+    my ($cv) = @_;
+    my $sym = objsym($cv);
+    if (defined($sym)) {
+#	warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
+	return $sym;
+    }
+    # Reserve a place in svsect and xpvcvsect and record indices
+    my $sv_ix = $svsect->index + 1;
+    $svsect->add("svix$sv_ix");
+    my $xpvcv_ix = $xpvcvsect->index + 1;
+    $xpvcvsect->add("xpvcvix$xpvcv_ix");
+    # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
+    $sym = savesym($cv, "&sv_list[$sv_ix]");
+    warn sprintf("saving CV 0x%x as $sym\n", $$cv) if $debug_cv;
+    my $gv = $cv->GV;
+    my $cvstashname = $gv->STASH->NAME;
+    my $cvname = $gv->NAME;
+    my $root = $cv->ROOT;
+    my $cvxsub = $cv->XSUB;
+    if (!$$root && !$cvxsub) {
+	if (try_autoload($cvstashname, $cvname)) {
+	    # Recalculate root and xsub
+	    $root = $cv->ROOT;
+	    $cvxsub = $cv->XSUB;
+	    if ($$root || $cvxsub) {
+		warn "Successful forced autoload\n";
+	    }
+	}
+    }
+    my $startfield = 0;
+    my $padlist = $cv->PADLIST;
+    my $pv = $cv->PV;
+    my $xsub = 0;
+    my $xsubany = "Nullany";
+    if ($$root) {
+	warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
+		     $$cv, $$root) if $debug_cv;
+	my $ppname = "";
+	if ($$gv) {
+	    my $stashname = $gv->STASH->NAME;
+	    my $gvname = $gv->NAME;
+	    if ($gvname ne "__ANON__") {
+		$ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
+		$ppname .= ($stashname eq "main") ?
+			    $gvname : "$stashname\::$gvname";
+		$ppname =~ s/::/__/g;
+	    }
+	}
+	if (!$ppname) {
+	    $ppname = "pp_anonsub_$anonsub_index";
+	    $anonsub_index++;
+	}
+	$startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
+	warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
+		     $$cv, $ppname, $$root) if $debug_cv;
+	if ($$padlist) {
+	    warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
+			 $$padlist, $$cv) if $debug_cv;
+	    $padlist->save;
+	    warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
+			 $$padlist, $$cv) if $debug_cv;
+	}
+    }
+    elsif ($cvxsub) {
+	$xsubany = sprintf("ANYINIT((void*)0x%x)", $cv->XSUBANY);
+	# Try to find out canonical name of XSUB function from EGV.
+	# XXX Doesn't work for XSUBs with PREFIX set (or anyone who
+	# calls newXS() manually with weird arguments).
+	my $egv = $gv->EGV;
+	my $stashname = $egv->STASH->NAME;
+	$stashname =~ s/::/__/g;
+	$xsub = sprintf("XS_%s_%s", $stashname, $egv->NAME);
+	$decl->add("void $xsub _((CV*));");
+    }
+    else {
+	warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
+		     $cvstashname, $cvname); # debug
+    }
+    $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, Nullgv, %d, s\\_%x, (CV*)s\\_%x, 0",
+			  $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
+			  $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
+			  $$padlist, ${$cv->OUTSIDE}));
+    if ($$gv) {
+	$gv->save;
+	$init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
+	warn sprintf("done saving GV 0x%x for CV 0x%x\n",
+		     $$gv, $$cv) if $debug_cv;
+    }
+    my $filegv = $cv->FILEGV;
+    if ($$filegv) {
+	$filegv->save;
+	$init->add(sprintf("CvFILEGV(s\\_%x) = s\\_%x;", $$cv, $$filegv));
+	warn sprintf("done saving FILEGV 0x%x for CV 0x%x\n",
+		     $$filegv, $$cv) if $debug_cv;
+    }
+    my $stash = $cv->STASH;
+    if ($$stash) {
+	$stash->save;
+	$init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
+	warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
+		     $$stash, $$cv) if $debug_cv;
+    }
+    $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
+			  $sv_ix, $xpvcv_ix, $cv->REFCNT + 1, $cv->FLAGS));
+    return $sym;
+}
+
+sub B::GV::save {
+    my ($gv) = @_;
+    my $sym = objsym($gv);
+    if (defined($sym)) {
+	#warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
+	return $sym;
+    } else {
+	my $ix = $gv_index++;
+	$sym = savesym($gv, "gv_list[$ix]");
+	#warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
+    }
+    my $gvname = $gv->NAME;
+    my $name = cstring($gv->STASH->NAME . "::" . $gvname);
+    #warn "GV name is $name\n"; # debug
+    my $egv = $gv->EGV;
+    my $egvsym;
+    if ($$gv != $$egv) {
+	#warn(sprintf("EGV name is %s, saving it now\n",
+	#	     $egv->STASH->NAME . "::" . $egv->NAME)); # debug
+	$egvsym = $egv->save;
+    }
+    $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
+	       sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
+	       sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS),
+	       sprintf("GvLINE($sym) = %u;", $gv->LINE));
+    # Shouldn't need to do save_magic since gv_fetchpv handles that
+    #$gv->save_magic;
+    my $refcnt = $gv->REFCNT + 1;
+    $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
+    my $gvrefcnt = $gv->GvREFCNT;
+    if ($gvrefcnt > 1) {
+	$init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
+    }
+    if (defined($egvsym)) {
+	# Shared glob *foo = *bar
+	$init->add("gp_free($sym);",
+		   "GvGP($sym) = GvGP($egvsym);");
+    } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
+	# Don't save subfields of special GVs (*_, *1, *# and so on)
+#	warn "GV::save saving subfields\n"; # debug
+	my $gvsv = $gv->SV;
+	if ($$gvsv) {
+	    $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
+#	    warn "GV::save \$$name\n"; # debug
+	    $gvsv->save;
+	}
+	my $gvav = $gv->AV;
+	if ($$gvav) {
+	    $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
+#	    warn "GV::save \@$name\n"; # debug
+	    $gvav->save;
+	}
+	my $gvhv = $gv->HV;
+	if ($$gvhv) {
+	    $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
+#	    warn "GV::save \%$name\n"; # debug
+	    $gvhv->save;
+	}
+	my $gvcv = $gv->CV;
+	if ($$gvcv) {
+	    $init->add(sprintf("GvCV($sym) = (CV*)s\\_%x;", $$gvcv));
+#	    warn "GV::save &$name\n"; # debug
+	    $gvcv->save;
+	}
+	my $gvfilegv = $gv->FILEGV;
+	if ($$gvfilegv) {
+	    $init->add(sprintf("GvFILEGV($sym) = s\\_%x;",$$gvfilegv));
+#	    warn "GV::save GvFILEGV(*$name)\n"; # debug
+	    $gvfilegv->save;
+	}
+	my $gvform = $gv->FORM;
+	if ($$gvform) {
+	    $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
+#	    warn "GV::save GvFORM(*$name)\n"; # debug
+	    $gvform->save;
+	}
+	my $gvio = $gv->IO;
+	if ($$gvio) {
+	    $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
+#	    warn "GV::save GvIO(*$name)\n"; # debug
+	    $gvio->save;
+	}
+    }
+    return $sym;
+}
+sub B::AV::save {
+    my ($av) = @_;
+    my $sym = objsym($av);
+    return $sym if defined $sym;
+    my $avflags = $av->AvFLAGS;
+    $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
+			    $avflags));
+    $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
+			 $xpvavsect->index, $av->REFCNT + 1, $av->FLAGS));
+    my $sv_list_index = $svsect->index;
+    my $fill = $av->FILL;
+    $av->save_magic;
+    warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
+	if $debug_av;
+    # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
+    #if ($fill > -1 && ($avflags & AVf_REAL)) {
+    if ($fill > -1) {
+	my @array = $av->ARRAY;
+	if ($debug_av) {
+	    my $el;
+	    my $i = 0;
+	    foreach $el (@array) {
+		warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
+			     $$av, $i++, class($el), $$el);
+	    }
+	}
+	my @names = map($_->save, @array);
+	# XXX Better ways to write loop?
+	# Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
+	# Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
+	$init->add("{",
+		   "\tSV **svp;",
+		   "\tAV *av = (AV*)&sv_list[$sv_list_index];",
+		   "\tav_extend(av, $fill);",
+		   "\tsvp = AvARRAY(av);",
+	       map("\t*svp++ = (SV*)$_;", @names),
+		   "\tAvFILLp(av) = $fill;",
+		   "}");
+    } else {
+	my $max = $av->MAX;
+	$init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
+	    if $max > -1;
+    }
+    return savesym($av, "(AV*)&sv_list[$sv_list_index]");
+}
+
+sub B::HV::save {
+    my ($hv) = @_;
+    my $sym = objsym($hv);
+    return $sym if defined $sym;
+    my $name = $hv->NAME;
+    if ($name) {
+	# It's a stash
+
+	# A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
+	# the only symptom is that sv_reset tries to reset the PMf_USED flag of
+	# a trashed op but we look at the trashed op_type and segfault.
+	#my $adpmroot = ${$hv->PMROOT};
+	my $adpmroot = 0;
+	$decl->add("static HV *hv$hv_index;");
+	# XXX Beware of weird package names containing double-quotes, \n, ...?
+	$init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
+	if ($adpmroot) {
+	    $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
+			       $adpmroot));
+	}
+	$sym = savesym($hv, "hv$hv_index");
+	$hv_index++;
+	return $sym;
+    }
+    # It's just an ordinary HV
+    $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
+			    $hv->MAX, $hv->RITER));
+    $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
+			 $xpvhvsect->index, $hv->REFCNT + 1, $hv->FLAGS));
+    my $sv_list_index = $svsect->index;
+    my @contents = $hv->ARRAY;
+    if (@contents) {
+	my $i;
+	for ($i = 1; $i < @contents; $i += 2) {
+	    $contents[$i] = $contents[$i]->save;
+	}
+	$init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
+	while (@contents) {
+	    my ($key, $value) = splice(@contents, 0, 2);
+	    $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
+			       cstring($key),length($key),$value, hash($key)));
+	}
+	$init->add("}");
+    }
+    return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
+}
+
+sub B::IO::save {
+    my ($io) = @_;
+    my $sym = objsym($io);
+    return $sym if defined $sym;
+    my $pv = $io->PV;
+    my $len = length($pv);
+    $xpviosect->add(sprintf("0, %u, %u, %d, %s, 0, 0, 0, 0, 0, %d, %d, %d, %d, %s, Nullgv, %s, Nullgv, %s, Nullgv, %d, %s, 0x%x",
+			    $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
+			    $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
+			    cstring($io->TOP_NAME), cstring($io->FMT_NAME), 
+			    cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
+			    cchar($io->IoTYPE), $io->IoFLAGS));
+    $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
+			 $xpviosect->index, $io->REFCNT + 1, $io->FLAGS));
+    $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
+    my ($field, $fsym);
+    foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
+      	$fsym = $io->$field();
+	if ($$fsym) {
+	    $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
+	    $fsym->save;
+	}
+    }
+    $io->save_magic;
+    return $sym;
+}
+
+sub B::SV::save {
+    my $sv = shift;
+    # This is where we catch an honest-to-goodness Nullsv (which gets
+    # blessed into B::SV explicitly) and any stray erroneous SVs.
+    return 0 unless $$sv;
+    confess sprintf("cannot save that type of SV: %s (0x%x)\n",
+		    class($sv), $$sv);
+}
+
+sub output_all {
+    my $init_name = shift;
+    my $section;
+    my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
+		    $listopsect, $pmopsect, $svopsect, $gvopsect, $pvopsect,
+		    $cvopsect, $loopsect, $copsect, $svsect, $xpvsect,
+		    $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
+		    $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
+    $symsect->output(\*STDOUT, "#define %s\n");
+    print "\n";
+    output_declarations();
+    foreach $section (@sections) {
+	my $lines = $section->index + 1;
+	if ($lines) {
+	    my $name = $section->name;
+	    my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
+	    print "Static $typename ${name}_list[$lines];\n";
+	}
+    }
+    $decl->output(\*STDOUT, "%s\n");
+    print "\n";
+    foreach $section (@sections) {
+	my $lines = $section->index + 1;
+	if ($lines) {
+	    my $name = $section->name;
+	    my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
+	    printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
+	    $section->output(\*STDOUT, "\t{ %s },\n");
+	    print "};\n\n";
+	}
+    }
+
+    print <<"EOT";
+static int $init_name()
+{
+	dTHR;
+EOT
+    $init->output(\*STDOUT, "\t%s\n");
+    print "\treturn 0;\n}\n";
+    if ($verbose) {
+	warn compile_stats();
+	warn "NULLOP count: $nullop_count\n";
+    }
+}
+
+sub output_declarations {
+    print <<'EOT';
+#ifdef BROKEN_STATIC_REDECL
+#define Static extern
+#else
+#define Static static
+#endif /* BROKEN_STATIC_REDECL */
+
+#ifdef BROKEN_UNION_INIT
+/*
+ * Cribbed from cv.h with ANY (a union) replaced by void*.
+ * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
+ */
+typedef struct {
+    char *	xpv_pv;		/* pointer to malloced string */
+    STRLEN	xpv_cur;	/* length of xp_pv as a C string */
+    STRLEN	xpv_len;	/* allocated size */
+    IV		xof_off;	/* integer value */
+    double	xnv_nv;		/* numeric value, if any */
+    MAGIC*	xmg_magic;	/* magic for scalar array */
+    HV*		xmg_stash;	/* class package */
+
+    HV *	xcv_stash;
+    OP *	xcv_start;
+    OP *	xcv_root;
+    void      (*xcv_xsub) _((CV*));
+    void *	xcv_xsubany;
+    GV *	xcv_gv;
+    GV *	xcv_filegv;
+    long	xcv_depth;		/* >= 2 indicates recursive call */
+    AV *	xcv_padlist;
+    CV *	xcv_outside;
+#ifdef USE_THREADS
+    perl_mutex *xcv_mutexp;
+    struct perl_thread *xcv_owner;	/* current owner thread */
+#endif /* USE_THREADS */
+    U8		xcv_flags;
+} XPVCV_or_similar;
+#define ANYINIT(i) i
+#else
+#define XPVCV_or_similar XPVCV
+#define ANYINIT(i) {i}
+#endif /* BROKEN_UNION_INIT */
+#define Nullany ANYINIT(0)
+
+#define UNUSED 0
+#define sym_0 0
+
+EOT
+    print "static GV *gv_list[$gv_index];\n" if $gv_index;
+    print "\n";
+}
+
+
+sub output_boilerplate {
+    print <<'EOT';
+#include "EXTERN.h"
+#include "perl.h"
+#ifndef PATCHLEVEL
+#include "patchlevel.h"
+#endif
+
+/* Workaround for mapstart: the only op which needs a different ppaddr */
+#undef pp_mapstart
+#define pp_mapstart pp_grepstart
+
+static void xs_init _((void));
+static PerlInterpreter *my_perl;
+EOT
+}
+
+sub output_main {
+    print <<'EOT';
+int
+#ifndef CAN_PROTOTYPE
+main(argc, argv, env)
+int argc;
+char **argv;
+char **env;
+#else  /* def(CAN_PROTOTYPE) */
+main(int argc, char **argv, char **env)
+#endif  /* def(CAN_PROTOTYPE) */
+{
+    int exitstatus;
+    int i;
+    char **fakeargv;
+
+    PERL_SYS_INIT(&argc,&argv);
+ 
+    perl_init_i18nl10n(1);
+
+    if (!do_undump) {
+	my_perl = perl_alloc();
+	if (!my_perl)
+	    exit(1);
+	perl_construct( my_perl );
+    }
+
+#ifdef CSH
+    if (!cshlen) 
+      cshlen = strlen(cshname);
+#endif
+
+#ifdef ALLOW_PERL_OPTIONS
+#define EXTRA_OPTIONS 2
+#else
+#define EXTRA_OPTIONS 3
+#endif /* ALLOW_PERL_OPTIONS */
+    New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
+    fakeargv[0] = argv[0];
+    fakeargv[1] = "-e";
+    fakeargv[2] = "";
+#ifndef ALLOW_PERL_OPTIONS
+    fakeargv[3] = "--";
+#endif /* ALLOW_PERL_OPTIONS */
+    for (i = 1; i < argc; i++)
+	fakeargv[i + EXTRA_OPTIONS] = argv[i];
+    fakeargv[argc + EXTRA_OPTIONS] = 0;
+    
+    exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
+			    fakeargv, NULL);
+    if (exitstatus)
+	exit( exitstatus );
+
+    sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
+    main_cv = compcv;
+    compcv = 0;
+
+    exitstatus = perl_init();
+    if (exitstatus)
+	exit( exitstatus );
+
+    exitstatus = perl_run( my_perl );
+
+    perl_destruct( my_perl );
+    perl_free( my_perl );
+
+    exit( exitstatus );
+}
+
+static void
+xs_init()
+{
+}
+EOT
+}
+
+sub dump_symtable {
+    # For debugging
+    my ($sym, $val);
+    warn "----Symbol table:\n";
+    while (($sym, $val) = each %symtable) {
+	warn "$sym => $val\n";
+    }
+    warn "---End of symbol table\n";
+}
+
+sub save_object {
+    my $sv;
+    foreach $sv (@_) {
+	svref_2object($sv)->save;
+    }
+}
+
+sub B::GV::savecv {
+    my $gv = shift;
+    my $cv = $gv->CV;
+    my $name = $gv->NAME;
+    if ($$cv && !objsym($cv) && !($name eq "bootstrap" && $cv->XSUB)) {
+	if ($debug_cv) {
+	    warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
+			 $gv->STASH->NAME, $name, $$cv, $$gv);
+	}
+	$gv->save;
+    }
+}
+
+sub save_unused_subs {
+    my %search_pack;
+    map { $search_pack{$_} = 1 } @_;
+    no strict qw(vars refs);
+    walksymtable(\%{"main::"}, "savecv", sub {
+	my $package = shift;
+	$package =~ s/::$//;
+	#warn "Considering $package\n";#debug
+	return 1 if exists $search_pack{$package};
+	#warn "    (nothing explicit)\n";#debug
+	# Omit the packages which we use (and which cause grief
+	# because of fancy "goto &$AUTOLOAD" stuff).
+	# XXX Surely there must be a nicer way to do this.
+	if ($package eq "FileHandle"
+	    || $package eq "Config"
+	    || $package eq "SelectSaver") {
+	    return 0;
+	}
+	my $m;
+	foreach $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH)) {
+	    if (defined(&{$package."::$m"})) {
+		warn "$package has method $m: -u$package assumed\n";#debug
+		return 1;
+	    }
+	}
+	return 0;
+    });
+}
+
+sub save_main {
+    my $curpad_sym = (comppadlist->ARRAY)[1]->save;
+    walkoptree(main_root, "save");
+    warn "done main optree, walking symtable for extras\n" if $debug_cv;
+    save_unused_subs(@unused_sub_packages);
+
+    $init->add(sprintf("main_root = s\\_%x;", ${main_root()}),
+	       sprintf("main_start = s\\_%x;", ${main_start()}),
+	       "curpad = AvARRAY($curpad_sym);");
+    output_boilerplate();
+    print "\n";
+    output_all("perl_init");
+    print "\n";
+    output_main();
+}
+
+sub init_sections {
+    my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
+		    binop => \$binopsect, condop => \$condopsect,
+		    cop => \$copsect, cvop => \$cvopsect, gvop => \$gvopsect,
+		    listop => \$listopsect, logop => \$logopsect,
+		    loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
+		    pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
+		    sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
+		    xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
+		    xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
+		    xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
+		    xrv => \$xrvsect, xpvbm => \$xpvbmsect,
+		    xpvio => \$xpviosect);
+    my ($name, $sectref);
+    while (($name, $sectref) = splice(@sections, 0, 2)) {
+	$$sectref = new B::Section $name, \%symtable, 0;
+    }
+}
+
+sub compile {
+    my @options = @_;
+    my ($option, $opt, $arg);
+  OPTION:
+    while ($option = shift @options) {
+	if ($option =~ /^-(.)(.*)/) {
+	    $opt = $1;
+	    $arg = $2;
+	} else {
+	    unshift @options, $option;
+	    last OPTION;
+	}
+	if ($opt eq "-" && $arg eq "-") {
+	    shift @options;
+	    last OPTION;
+	}
+	if ($opt eq "w") {
+	    $warn_undefined_syms = 1;
+	} elsif ($opt eq "D") {
+	    $arg ||= shift @options;
+	    foreach $arg (split(//, $arg)) {
+		if ($arg eq "o") {
+		    B->debug(1);
+		} elsif ($arg eq "c") {
+		    $debug_cops = 1;
+		} elsif ($arg eq "A") {
+		    $debug_av = 1;
+		} elsif ($arg eq "C") {
+		    $debug_cv = 1;
+		} elsif ($arg eq "M") {
+		    $debug_mg = 1;
+		} else {
+		    warn "ignoring unknown debug option: $arg\n";
+		}
+	    }
+	} elsif ($opt eq "o") {
+	    $arg ||= shift @options;
+	    open(STDOUT, ">$arg") or return "$arg: $!\n";
+	} elsif ($opt eq "v") {
+	    $verbose = 1;
+	} elsif ($opt eq "u") {
+	    $arg ||= shift @options;
+	    push(@unused_sub_packages, $arg);
+	} elsif ($opt eq "f") {
+	    $arg ||= shift @options;
+	    if ($arg eq "cog") {
+		$pv_copy_on_grow = 1;
+	    } elsif ($arg eq "no-cog") {
+		$pv_copy_on_grow = 0;
+	    }
+	} elsif ($opt eq "O") {
+	    $arg = 1 if $arg eq "";
+	    $pv_copy_on_grow = 0;
+	    if ($arg >= 1) {
+		# Optimisations for -O1
+		$pv_copy_on_grow = 1;
+	    }
+	}
+    }
+    init_sections();
+    if (@options) {
+	return sub {
+	    my $objname;
+	    foreach $objname (@options) {
+		eval "save_object(\\$objname)";
+	    }
+	    output_all();
+	}
+    } else {
+	return sub { save_main() };
+    }
+}
+
+1;
diff --git a/ext/B/B/CC.pm b/ext/B/B/CC.pm
new file mode 100644
index 0000000000..fc7cf6dad2
--- /dev/null
+++ b/ext/B/B/CC.pm
@@ -0,0 +1,1528 @@
+#      CC.pm
+#
+#      Copyright (c) 1996, 1997 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.
+#
+package B::CC;
+use strict;
+use B qw(main_start main_root class comppadlist peekop svref_2object
+	timing_info);
+use B::C qw(save_unused_subs objsym init_sections
+	    output_all output_boilerplate output_main);
+use B::Bblock qw(find_leaders);
+use B::Stackobj qw(:types :flags);
+
+# These should probably be elsewhere
+# Flags for $op->flags
+sub OPf_LIST () { 1 }
+sub OPf_KNOW () { 2 }
+sub OPf_MOD () { 32 }
+sub OPf_STACKED () { 64 }
+sub OPf_SPECIAL () { 128 }
+# op-specific flags for $op->private 
+sub OPpASSIGN_BACKWARDS () { 64 }
+sub OPpLVAL_INTRO () { 128 }
+sub OPpDEREF_AV () { 32 }
+sub OPpDEREF_HV () { 64 }
+sub OPpDEREF () { OPpDEREF_AV|OPpDEREF_HV }
+sub OPpFLIP_LINENUM () { 64 }
+sub G_ARRAY () { 1 }
+# cop.h
+sub CXt_NULL () { 0 }
+sub CXt_SUB () { 1 }
+sub CXt_EVAL () { 2 }
+sub CXt_LOOP () { 3 }
+sub CXt_SUBST () { 4 }
+sub CXt_BLOCK () { 5 }
+
+my $module;		# module name (when compiled with -m)
+my %done;		# hash keyed by $$op of leaders of basic blocks
+			# which have already been done.
+my $leaders;		# ref to hash of basic block leaders. Keys are $$op
+			# addresses, values are the $op objects themselves.
+my @bblock_todo;	# list of leaders of basic blocks that need visiting
+			# sometime.
+my @cc_todo;		# list of tuples defining what PP code needs to be
+			# saved (e.g. CV, main or PMOP repl code). Each tuple
+			# is [$name, $root, $start, @padlist]. PMOP repl code
+			# tuples inherit padlist.
+my @stack;		# shadows perl's stack when contents are known.
+			# Values are objects derived from class B::Stackobj
+my @pad;		# Lexicals in current pad as Stackobj-derived objects
+my @padlist;		# Copy of current padlist so PMOP repl code can find it
+my @cxstack;		# Shadows the (compile-time) cxstack for next,last,redo
+my $jmpbuf_ix = 0;	# Next free index for dynamically allocated jmpbufs
+my %constobj;		# OP_CONST constants as Stackobj-derived objects
+			# keyed by $$sv.
+my $need_freetmps = 0;	# We may postpone FREETMPS to the end of each basic
+			# block or even to the end of each loop of blocks,
+			# depending on optimisation options.
+my $know_op = 0;	# Set when C variable op already holds the right op
+			# (from an immediately preceding DOOP(ppname)).
+my $errors = 0;		# Number of errors encountered
+my %skip_stack;		# Hash of PP names which don't need write_back_stack
+my %skip_lexicals;	# Hash of PP names which don't need write_back_lexicals
+my %skip_invalidate;	# Hash of PP names which don't need invalidate_lexicals
+my %ignore_op;		# Hash of ops which do nothing except returning op_next
+
+BEGIN {
+    foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) {
+	$ignore_op{$_} = 1;
+    }
+}
+
+my @unused_sub_packages; # list of packages (given by -u options) to search
+			 # explicitly and save every sub we find there, even
+			 # if apparently unused (could be only referenced from
+			 # an eval "" or from a $SIG{FOO} = "bar").
+
+my ($module_name);
+my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime,
+    $debug_shadow, $debug_queue, $debug_lineno, $debug_timings);
+
+# 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 ($freetmps_each_bblock, $freetmps_each_loop, $omit_taint);
+my %optimise = (freetmps_each_bblock	=> \$freetmps_each_bblock,
+		freetmps_each_loop	=> \$freetmps_each_loop,
+		omit_taint		=> \$omit_taint);
+# perl patchlevel to generate code for (defaults to current patchlevel)
+my $patchlevel = int(0.5 + 1000 * ($]  - 5));
+
+# Could rewrite push_runtime() and output_runtime() to use a
+# temporary file if memory is at a premium.
+my $ppname;		# name of current fake PP function
+my $runtime_list_ref;
+my $declare_ref;	# Hash ref keyed by C variable type of declarations.
+
+my @pp_list;		# list of [$ppname, $runtime_list_ref, $declare_ref]
+			# tuples to be written out.
+
+my ($init, $decl);
+
+sub init_hash { map { $_ => 1 } @_ }
+
+#
+# Initialise the hashes for the default PP functions where we can avoid
+# either write_back_stack, write_back_lexicals or invalidate_lexicals.
+#
+%skip_lexicals = init_hash qw(pp_enter pp_enterloop);
+%skip_invalidate = init_hash qw(pp_enter pp_enterloop);
+
+sub debug {
+    if ($debug_runtime) {
+	warn(@_);
+    } else {
+	runtime(map { chomp; "/* $_ */"} @_);
+    }
+}
+
+sub declare {
+    my ($type, $var) = @_;
+    push(@{$declare_ref->{$type}}, $var);
+}
+
+sub push_runtime {
+    push(@$runtime_list_ref, @_);
+    warn join("\n", @_) . "\n" if $debug_runtime;
+}
+
+sub save_runtime {
+    push(@pp_list, [$ppname, $runtime_list_ref, $declare_ref]);
+}
+
+sub output_runtime {
+    my $ppdata;
+    print qq(#include "cc_runtime.h"\n);
+    foreach $ppdata (@pp_list) {
+	my ($name, $runtime, $declare) = @$ppdata;
+	print "\nstatic\nPP($name)\n{\n";
+	my ($type, $varlist, $line);
+	while (($type, $varlist) = each %$declare) {
+	    print "\t$type ", join(", ", @$varlist), ";\n";
+	}
+	foreach $line (@$runtime) {
+	    print $line, "\n";
+	}
+	print "}\n";
+    }
+}
+
+sub runtime {
+    my $line;
+    foreach $line (@_) {
+	push_runtime("\t$line");
+    }
+}
+
+sub init_pp {
+    $ppname = shift;
+    $runtime_list_ref = [];
+    $declare_ref = {};
+    runtime("djSP;");
+    declare("I32", "oldsave");
+    declare("SV", "**svp");
+    map { declare("SV", "*$_") } qw(sv src dst left right);
+    declare("MAGIC", "*mg");
+    $decl->add("static OP * $ppname _((ARGSproto));");
+    debug "init_pp: $ppname\n" if $debug_queue;
+}
+
+# Initialise runtime_callback function for Stackobj class
+BEGIN { B::Stackobj::set_callback(\&runtime) }
+
+# Initialise saveoptree_callback for B::C class
+sub cc_queue {
+    my ($name, $root, $start, @pl) = @_;
+    debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n"
+	if $debug_queue;
+    if ($name eq "*ignore*") {
+	$name = 0;
+    } else {
+	push(@cc_todo, [$name, $root, $start, (@pl ? @pl : @padlist)]);
+    }
+    my $fakeop = new B::FAKEOP ("next" => 0, sibling => 0, ppaddr => $name);
+    $start = $fakeop->save;
+    debug "cc_queue: name $name returns $start\n" if $debug_queue;
+    return $start;
+}
+BEGIN { B::C::set_callback(\&cc_queue) }
+
+sub valid_int { $_[0]->{flags} & VALID_INT }
+sub valid_double { $_[0]->{flags} & VALID_DOUBLE }
+sub valid_numeric { $_[0]->{flags} & (VALID_INT | VALID_DOUBLE) }
+sub valid_sv { $_[0]->{flags} & VALID_SV }
+
+sub top_int { @stack ? $stack[-1]->as_int : "TOPi" }
+sub top_double { @stack ? $stack[-1]->as_double : "TOPn" }
+sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" }
+sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" }
+sub top_bool { @stack ? $stack[-1]->as_numeric : "SvTRUE(TOPs)" }
+
+sub pop_int { @stack ? (pop @stack)->as_int : "POPi" }
+sub pop_double { @stack ? (pop @stack)->as_double : "POPn" }
+sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" }
+sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" }
+sub pop_bool {
+    if (@stack) {
+	return ((pop @stack)->as_numeric);
+    } else {
+	# Careful: POPs has an auto-decrement and SvTRUE evaluates
+	# its argument more than once.
+	runtime("sv = POPs;");
+	return "SvTRUE(sv)";
+    }
+}
+
+sub write_back_lexicals {
+    my $avoid = shift || 0;
+    debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
+	if $debug_shadow;
+    my $lex;
+    foreach $lex (@pad) {
+	next unless ref($lex);
+	$lex->write_back unless $lex->{flags} & $avoid;
+    }
+}
+
+sub write_back_stack {
+    my $obj;
+    return unless @stack;
+    runtime(sprintf("EXTEND(sp, %d);", scalar(@stack)));
+    foreach $obj (@stack) {
+	runtime(sprintf("PUSHs((SV*)%s);", $obj->as_sv));
+    }
+    @stack = ();
+}
+
+sub invalidate_lexicals {
+    my $avoid = shift || 0;
+    debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
+	if $debug_shadow;
+    my $lex;
+    foreach $lex (@pad) {
+	next unless ref($lex);
+	$lex->invalidate unless $lex->{flags} & $avoid;
+    }
+}
+
+sub reload_lexicals {
+    my $lex;
+    foreach $lex (@pad) {
+	next unless ref($lex);
+	my $type = $lex->{type};
+	if ($type == T_INT) {
+	    $lex->as_int;
+	} elsif ($type == T_DOUBLE) {
+	    $lex->as_double;
+	} else {
+	    $lex->as_sv;
+	}
+    }
+}
+
+{
+    package B::Pseudoreg;
+    #
+    # This class allocates pseudo-registers (OK, so they're C variables).
+    #
+    my %alloc;		# Keyed by variable name. A value of 1 means the
+			# variable has been declared. A value of 2 means
+			# it's in use.
+    
+    sub new_scope { %alloc = () }
+    
+    sub new ($$$) {
+	my ($class, $type, $prefix) = @_;
+	my ($ptr, $i, $varname, $status, $obj);
+	$prefix =~ s/^(\**)//;
+	$ptr = $1;
+	$i = 0;
+	do {
+	    $varname = "$prefix$i";
+	    $status = $alloc{$varname};
+	} while $status == 2;
+	if ($status != 1) {
+	    # Not declared yet
+	    B::CC::declare($type, "$ptr$varname");
+	    $alloc{$varname} = 2;	# declared and in use
+	}
+	$obj = bless \$varname, $class;
+	return $obj;
+    }
+    sub DESTROY {
+	my $obj = shift;
+	$alloc{$$obj} = 1; # no longer in use but still declared
+    }
+}
+{
+    package B::Shadow;
+    #
+    # This class gives a standard API for a perl object to shadow a
+    # C variable and only generate reloads/write-backs when necessary.
+    #
+    # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo").
+    # Use $obj->write_back whenever shadowed_c_var needs to be up to date.
+    # Use $obj->invalidate whenever an unknown function may have
+    # set shadow itself.
+
+    sub new {
+	my ($class, $write_back) = @_;
+	# Object fields are perl shadow variable, validity flag
+	# (for *C* variable) and callback sub for write_back
+	# (passed perl shadow variable as argument).
+	bless [undef, 1, $write_back], $class;
+    }
+    sub load {
+	my ($obj, $newval) = @_;
+	$obj->[1] = 0;		# C variable no longer valid
+	$obj->[0] = $newval;
+    }
+    sub write_back {
+	my $obj = shift;
+	if (!($obj->[1])) {
+	    $obj->[1] = 1;	# C variable will now be valid
+	    &{$obj->[2]}($obj->[0]);
+	}
+    }
+    sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid
+}
+my $curcop = new B::Shadow (sub {
+    my $opsym = shift->save;
+    runtime("curcop = (COP*)$opsym;");
+});
+
+#
+# Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on.
+#
+sub dopoptoloop {
+    my $cxix = $#cxstack;
+    while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP) {
+	$cxix--;
+    }
+    debug "dopoptoloop: returning $cxix" if $debug_cxstack;
+    return $cxix;
+}
+
+sub dopoptolabel {
+    my $label = shift;
+    my $cxix = $#cxstack;
+    while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP
+	   && $cxstack[$cxix]->{label} ne $label) {
+	$cxix--;
+    }
+    debug "dopoptolabel: returning $cxix" if $debug_cxstack;
+    return $cxix;
+}
+
+sub error {
+    my $format = shift;
+    my $file = $curcop->[0]->filegv->SV->PV;
+    my $line = $curcop->[0]->line;
+    $errors++;
+    if (@_) {
+	warn sprintf("%s:%d: $format\n", $file, $line, @_);
+    } else {
+	warn sprintf("%s:%d: %s\n", $file, $line, $format);
+    }
+}
+
+#
+# Load pad takes (the elements of) a PADLIST as arguments and loads
+# up @pad with Stackobj-derived objects which represent those lexicals.
+# If/when perl itself can generate type information (my int $foo) then
+# we'll take advantage of that here. Until then, we'll use various hacks
+# to tell the compiler when we want a lexical to be a particular type
+# or to be a register.
+#
+sub load_pad {
+    my ($namelistav, $valuelistav) = @_;
+    @padlist = @_;
+    my @namelist = $namelistav->ARRAY;
+    my @valuelist = $valuelistav->ARRAY;
+    my $ix;
+    @pad = ();
+    debug "load_pad: $#namelist names, $#valuelist values\n" if $debug_pad;
+    # Temporary lexicals don't get named so it's possible for @valuelist
+    # to be strictly longer than @namelist. We count $ix up to the end of
+    # @valuelist but index into @namelist for the name. Any temporaries which
+    # run off the end of @namelist will make $namesv undefined and we treat
+    # that the same as having an explicit SPECIAL sv_undef object in @namelist.
+    # [XXX If/when @_ becomes a lexical, we must start at 0 here.]
+    for ($ix = 1; $ix < @valuelist; $ix++) {
+	my $namesv = $namelist[$ix];
+	my $type = T_UNKNOWN;
+	my $flags = 0;
+	my $name = "tmp$ix";
+	my $class = class($namesv);
+	if (!defined($namesv) || $class eq "SPECIAL") {
+	    # temporaries have &sv_undef instead of a PVNV for a name
+	    $flags = VALID_SV|TEMPORARY|REGISTER;
+	} else {
+	    if ($namesv->PV =~ /^\$(.*)_([di])(r?)$/) {
+		$name = $1;
+		if ($2 eq "i") {
+		    $type = T_INT;
+		    $flags = VALID_SV|VALID_INT;
+		} elsif ($2 eq "d") {
+		    $type = T_DOUBLE;
+		    $flags = VALID_SV|VALID_DOUBLE;
+		}
+		$flags |= REGISTER if $3;
+	    }
+	}
+	$pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix,
+					    "i_$name", "d_$name");
+	declare("IV", $type == T_INT ? "i_$name = 0" : "i_$name");
+	declare("double", $type == T_DOUBLE ? "d_$name = 0" : "d_$name");
+	debug sprintf("curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad;
+    }
+}
+
+#
+# Debugging stuff
+#
+sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) }
+
+#
+# OP stuff
+#
+
+sub label {
+    my $op = shift;
+    # XXX Preserve original label name for "real" labels?
+    return sprintf("lab_%x", $$op);
+}
+
+sub write_label {
+    my $op = shift;
+    push_runtime(sprintf("  %s:", label($op)));
+}
+
+sub loadop {
+    my $op = shift;
+    my $opsym = $op->save;
+    runtime("op = $opsym;") unless $know_op;
+    return $opsym;
+}
+
+sub doop {
+    my $op = shift;
+    my $ppname = $op->ppaddr;
+    my $sym = loadop($op);
+    runtime("DOOP($ppname);");
+    $know_op = 1;
+    return $sym;
+}
+
+sub gimme {
+    my $op = shift;
+    my $flags = $op->flags;
+    return (($flags & OPf_KNOW) ? ($flags & OPf_LIST) : "dowantarray()");
+}
+
+#
+# Code generation for PP code
+#
+
+sub pp_null {
+    my $op = shift;
+    return $op->next;
+}
+
+sub pp_stub {
+    my $op = shift;
+    my $gimme = gimme($op);
+    if ($gimme != 1) {
+	# XXX Change to push a constant sv_undef Stackobj onto @stack
+	write_back_stack();
+	runtime("if ($gimme != G_ARRAY) XPUSHs(&sv_undef);");
+    }
+    return $op->next;
+}
+
+sub pp_unstack {
+    my $op = shift;
+    @stack = ();
+    runtime("PP_UNSTACK;");
+    return $op->next;
+}
+
+sub pp_and {
+    my $op = shift;
+    my $next = $op->next;
+    reload_lexicals();
+    unshift(@bblock_todo, $next);
+    if (@stack >= 1) {
+	my $bool = pop_bool();
+	write_back_stack();
+	runtime(sprintf("if (!$bool) goto %s;", label($next)));
+    } else {
+	runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)),
+		"*sp--;");
+    }
+    return $op->other;
+}
+	    
+sub pp_or {
+    my $op = shift;
+    my $next = $op->next;
+    reload_lexicals();
+    unshift(@bblock_todo, $next);
+    if (@stack >= 1) {
+	my $obj = pop @stack;
+	write_back_stack();
+	runtime(sprintf("if (%s) { XPUSHs(%s); goto %s; }",
+			$obj->as_numeric, $obj->as_sv, label($next)));
+    } else {
+	runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
+		"*sp--;");
+    }
+    return $op->other;
+}
+	    
+sub pp_cond_expr {
+    my $op = shift;
+    my $false = $op->false;
+    unshift(@bblock_todo, $false);
+    reload_lexicals();
+    my $bool = pop_bool();
+    write_back_stack();
+    runtime(sprintf("if (!$bool) goto %s;", label($false)));
+    return $op->true;
+}
+
+sub pp_padsv {
+    my $op = shift;
+    my $ix = $op->targ;
+    push(@stack, $pad[$ix]);
+    if ($op->flags & OPf_MOD) {
+	my $private = $op->private;
+	if ($private & OPpLVAL_INTRO) {
+	    runtime("SAVECLEARSV(curpad[$ix]);");
+	} elsif ($private & OPpDEREF) {
+	    runtime(sprintf("vivify_ref(curpad[%d], %d);",
+			    $ix, $private & OPpDEREF));
+	    $pad[$ix]->invalidate;
+	}
+    }
+    return $op->next;
+}
+
+sub pp_const {
+    my $op = shift;
+    my $sv = $op->sv;
+    my $obj = $constobj{$$sv};
+    if (!defined($obj)) {
+	$obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
+    }
+    push(@stack, $obj);
+    return $op->next;
+}
+
+sub pp_nextstate {
+    my $op = shift;
+    $curcop->load($op);
+    @stack = ();
+    debug(sprintf("%s:%d\n", $op->filegv->SV->PV, $op->line)) if $debug_lineno;
+    runtime("TAINT_NOT;") unless $omit_taint;
+    runtime("sp = stack_base + cxstack[cxstack_ix].blk_oldsp;");
+    if ($freetmps_each_bblock || $freetmps_each_loop) {
+	$need_freetmps = 1;
+    } else {
+	runtime("FREETMPS;");
+    }
+    return $op->next;
+}
+
+sub pp_dbstate {
+    my $op = shift;
+    $curcop->invalidate; # XXX?
+    return default_pp($op);
+}
+
+sub pp_rv2gv { $curcop->write_back; default_pp(@_) }
+sub pp_bless { $curcop->write_back; default_pp(@_) }
+sub pp_repeat { $curcop->write_back; default_pp(@_) }
+# The following subs need $curcop->write_back if we decide to support arybase:
+# pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice
+sub pp_sort { $curcop->write_back; default_pp(@_) }
+sub pp_caller { $curcop->write_back; default_pp(@_) }
+sub pp_reset { $curcop->write_back; default_pp(@_) }
+
+sub pp_gv {
+    my $op = shift;
+    my $gvsym = $op->gv->save;
+    write_back_stack();
+    runtime("XPUSHs((SV*)$gvsym);");
+    return $op->next;
+}
+
+sub pp_gvsv {
+    my $op = shift;
+    my $gvsym = $op->gv->save;
+    write_back_stack();
+    if ($op->private & OPpLVAL_INTRO) {
+	runtime("XPUSHs(save_scalar($gvsym));");
+    } else {
+	runtime("XPUSHs(GvSV($gvsym));");
+    }
+    return $op->next;
+}
+
+sub pp_aelemfast {
+    my $op = shift;
+    my $gvsym = $op->gv->save;
+    my $ix = $op->private;
+    my $flag = $op->flags & OPf_MOD;
+    write_back_stack();
+    runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);",
+	    "PUSHs(svp ? *svp : &sv_undef);");
+    return $op->next;
+}
+
+sub int_binop {
+    my ($op, $operator) = @_;
+    if ($op->flags & OPf_STACKED) {
+	my $right = pop_int();
+	if (@stack >= 1) {
+	    my $left = top_int();
+	    $stack[-1]->set_int(&$operator($left, $right));
+	} else {
+	    runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right)));
+	}
+    } else {
+	my $targ = $pad[$op->targ];
+	my $right = new B::Pseudoreg ("IV", "riv");
+	my $left = new B::Pseudoreg ("IV", "liv");
+	runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int));
+	$targ->set_int(&$operator($$left, $$right));
+	push(@stack, $targ);
+    }
+    return $op->next;
+}
+
+sub INTS_CLOSED () { 0x1 }
+sub INT_RESULT () { 0x2 }
+sub NUMERIC_RESULT () { 0x4 }
+
+sub numeric_binop {
+    my ($op, $operator, $flags) = @_;
+    my $force_int = 0;
+    $force_int ||= ($flags & INT_RESULT);
+    $force_int ||= ($flags & INTS_CLOSED && @stack >= 2
+		    && valid_int($stack[-2]) && valid_int($stack[-1]));
+    if ($op->flags & OPf_STACKED) {
+	my $right = pop_numeric();
+	if (@stack >= 1) {
+	    my $left = top_numeric();
+	    if ($force_int) {
+		$stack[-1]->set_int(&$operator($left, $right));
+	    } else {
+		$stack[-1]->set_numeric(&$operator($left, $right));
+	    }
+	} else {
+	    if ($force_int) {
+		runtime(sprintf("sv_setiv(TOPs, %s);",
+				&$operator("TOPi", $right)));
+	    } else {
+		runtime(sprintf("sv_setnv(TOPs, %s);",
+				&$operator("TOPn", $right)));
+	    }
+	}
+    } else {
+	my $targ = $pad[$op->targ];
+	$force_int ||= ($targ->{type} == T_INT);
+	if ($force_int) {
+	    my $right = new B::Pseudoreg ("IV", "riv");
+	    my $left = new B::Pseudoreg ("IV", "liv");
+	    runtime(sprintf("$$right = %s; $$left = %s;",
+			    pop_numeric(), pop_numeric));
+	    $targ->set_int(&$operator($$left, $$right));
+	} else {
+	    my $right = new B::Pseudoreg ("double", "rnv");
+	    my $left = new B::Pseudoreg ("double", "lnv");
+	    runtime(sprintf("$$right = %s; $$left = %s;",
+			    pop_numeric(), pop_numeric));
+	    $targ->set_numeric(&$operator($$left, $$right));
+	}
+	push(@stack, $targ);
+    }
+    return $op->next;
+}
+
+sub sv_binop {
+    my ($op, $operator, $flags) = @_;
+    if ($op->flags & OPf_STACKED) {
+	my $right = pop_sv();
+	if (@stack >= 1) {
+	    my $left = top_sv();
+	    if ($flags & INT_RESULT) {
+		$stack[-1]->set_int(&$operator($left, $right));
+	    } elsif ($flags & NUMERIC_RESULT) {
+		$stack[-1]->set_numeric(&$operator($left, $right));
+	    } else {
+		# XXX Does this work?
+		runtime(sprintf("sv_setsv($left, %s);",
+				&$operator($left, $right)));
+		$stack[-1]->invalidate;
+	    }
+	} else {
+	    my $f;
+	    if ($flags & INT_RESULT) {
+		$f = "sv_setiv";
+	    } elsif ($flags & NUMERIC_RESULT) {
+		$f = "sv_setnv";
+	    } else {
+		$f = "sv_setsv";
+	    }
+	    runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right)));
+	}
+    } else {
+	my $targ = $pad[$op->targ];
+	runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv));
+	if ($flags & INT_RESULT) {
+	    $targ->set_int(&$operator("left", "right"));
+	} elsif ($flags & NUMERIC_RESULT) {
+	    $targ->set_numeric(&$operator("left", "right"));
+	} else {
+	    # XXX Does this work?
+	    runtime(sprintf("sv_setsv(%s, %s);",
+			    $targ->as_sv, &$operator("left", "right")));
+	    $targ->invalidate;
+	}
+	push(@stack, $targ);
+    }
+    return $op->next;
+}
+    
+sub bool_int_binop {
+    my ($op, $operator) = @_;
+    my $right = new B::Pseudoreg ("IV", "riv");
+    my $left = new B::Pseudoreg ("IV", "liv");
+    runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int()));
+    my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
+    $bool->set_int(&$operator($$left, $$right));
+    push(@stack, $bool);
+    return $op->next;
+}
+
+sub bool_numeric_binop {
+    my ($op, $operator) = @_;
+    my $right = new B::Pseudoreg ("double", "rnv");
+    my $left = new B::Pseudoreg ("double", "lnv");
+    runtime(sprintf("$$right = %s; $$left = %s;",
+		    pop_numeric(), pop_numeric()));
+    my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
+    $bool->set_numeric(&$operator($$left, $$right));
+    push(@stack, $bool);
+    return $op->next;
+}
+
+sub bool_sv_binop {
+    my ($op, $operator) = @_;
+    runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv()));
+    my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
+    $bool->set_numeric(&$operator("left", "right"));
+    push(@stack, $bool);
+    return $op->next;
+}
+
+sub infix_op {
+    my $opname = shift;
+    return sub { "$_[0] $opname $_[1]" }
+}
+
+sub prefix_op {
+    my $opname = shift;
+    return sub { sprintf("%s(%s)", $opname, join(", ", @_)) }
+}
+
+BEGIN {
+    my $plus_op = infix_op("+");
+    my $minus_op = infix_op("-");
+    my $multiply_op = infix_op("*");
+    my $divide_op = infix_op("/");
+    my $modulo_op = infix_op("%");
+    my $lshift_op = infix_op("<<");
+    my $rshift_op = infix_op("<<");
+    my $ncmp_op = sub { "($_[0] > $_[1] ? 1 : ($_[0] < $_[1]) ? -1 : 0)" };
+    my $scmp_op = prefix_op("sv_cmp");
+    my $seq_op = prefix_op("sv_eq");
+    my $sne_op = prefix_op("!sv_eq");
+    my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" };
+    my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" };
+    my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" };
+    my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" };
+    my $eq_op = infix_op("==");
+    my $ne_op = infix_op("!=");
+    my $lt_op = infix_op("<");
+    my $gt_op = infix_op(">");
+    my $le_op = infix_op("<=");
+    my $ge_op = infix_op(">=");
+
+    #
+    # XXX The standard perl PP code has extra handling for
+    # some special case arguments of these operators.
+    #
+    sub pp_add { numeric_binop($_[0], $plus_op, INTS_CLOSED) }
+    sub pp_subtract { numeric_binop($_[0], $minus_op, INTS_CLOSED) }
+    sub pp_multiply { numeric_binop($_[0], $multiply_op, INTS_CLOSED) }
+    sub pp_divide { numeric_binop($_[0], $divide_op) }
+    sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's
+    sub pp_ncmp { numeric_binop($_[0], $ncmp_op, INT_RESULT) }
+
+    sub pp_left_shift { int_binop($_[0], $lshift_op) }
+    sub pp_right_shift { int_binop($_[0], $rshift_op) }
+    sub pp_i_add { int_binop($_[0], $plus_op) }
+    sub pp_i_subtract { int_binop($_[0], $minus_op) }
+    sub pp_i_multiply { int_binop($_[0], $multiply_op) }
+    sub pp_i_divide { int_binop($_[0], $divide_op) }
+    sub pp_i_modulo { int_binop($_[0], $modulo_op) }
+
+    sub pp_eq { bool_numeric_binop($_[0], $eq_op) }
+    sub pp_ne { bool_numeric_binop($_[0], $ne_op) }
+    sub pp_lt { bool_numeric_binop($_[0], $lt_op) }
+    sub pp_gt { bool_numeric_binop($_[0], $gt_op) }
+    sub pp_le { bool_numeric_binop($_[0], $le_op) }
+    sub pp_ge { bool_numeric_binop($_[0], $ge_op) }
+
+    sub pp_i_eq { bool_int_binop($_[0], $eq_op) }
+    sub pp_i_ne { bool_int_binop($_[0], $ne_op) }
+    sub pp_i_lt { bool_int_binop($_[0], $lt_op) }
+    sub pp_i_gt { bool_int_binop($_[0], $gt_op) }
+    sub pp_i_le { bool_int_binop($_[0], $le_op) }
+    sub pp_i_ge { bool_int_binop($_[0], $ge_op) }
+
+    sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) }
+    sub pp_slt { bool_sv_binop($_[0], $slt_op) }
+    sub pp_sgt { bool_sv_binop($_[0], $sgt_op) }
+    sub pp_sle { bool_sv_binop($_[0], $sle_op) }
+    sub pp_sge { bool_sv_binop($_[0], $sge_op) }
+    sub pp_seq { bool_sv_binop($_[0], $seq_op) }
+    sub pp_sne { bool_sv_binop($_[0], $sne_op) }
+}
+
+
+sub pp_sassign {
+    my $op = shift;
+    my $backwards = $op->private & OPpASSIGN_BACKWARDS;
+    my ($dst, $src);
+    if (@stack >= 2) {
+	$dst = pop @stack;
+	$src = pop @stack;
+	($src, $dst) = ($dst, $src) if $backwards;
+	my $type = $src->{type};
+	if ($type == T_INT) {
+	    $dst->set_int($src->as_int);
+	} elsif ($type == T_DOUBLE) {
+	    $dst->set_numeric($src->as_numeric);
+	} else {
+	    $dst->set_sv($src->as_sv);
+	}
+	push(@stack, $dst);
+    } elsif (@stack == 1) {
+	if ($backwards) {
+	    my $src = pop @stack;
+	    my $type = $src->{type};
+	    runtime("if (tainting && tainted) TAINT_NOT;");
+	    if ($type == T_INT) {
+		runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int);
+	    } elsif ($type == T_DOUBLE) {
+		runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double);
+	    } else {
+		runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv);
+	    }
+	    runtime("SvSETMAGIC(TOPs);");
+	} else {
+	    my $dst = pop @stack;
+	    my $type = $dst->{type};
+	    runtime("sv = POPs;");
+	    runtime("MAYBE_TAINT_SASSIGN_SRC(sv);");
+	    if ($type == T_INT) {
+		$dst->set_int("SvIV(sv)");
+	    } elsif ($type == T_DOUBLE) {
+		$dst->set_double("SvNV(sv)");
+	    } else {
+		runtime("SvSetSV($dst->{sv}, sv);");
+		$dst->invalidate;
+	    }
+	}
+    } else {
+	if ($backwards) {
+	    runtime("src = POPs; dst = TOPs;");
+	} else {
+	    runtime("dst = POPs; src = TOPs;");
+	}
+	runtime("MAYBE_TAINT_SASSIGN_SRC(src);",
+		"SvSetSV(dst, src);",
+		"SvSETMAGIC(dst);",
+		"SETs(dst);");
+    }
+    return $op->next;
+}
+
+sub pp_preinc {
+    my $op = shift;
+    if (@stack >= 1) {
+	my $obj = $stack[-1];
+	my $type = $obj->{type};
+	if ($type == T_INT || $type == T_DOUBLE) {
+	    $obj->set_int($obj->as_int . " + 1");
+	} else {
+	    runtime sprintf("PP_PREINC(%s);", $obj->as_sv);
+	    $obj->invalidate();
+	}
+    } else {
+	runtime sprintf("PP_PREINC(TOPs);");
+    }
+    return $op->next;
+}
+
+sub pp_pushmark {
+    my $op = shift;
+    write_back_stack();
+    runtime("PUSHMARK(sp);");
+    return $op->next;
+}
+
+sub pp_list {
+    my $op = shift;
+    write_back_stack();
+    my $gimme = gimme($op);
+    if ($gimme == 1) { # sic
+	runtime("POPMARK;"); # need this even though not a "full" pp_list
+    } else {
+	runtime("PP_LIST($gimme);");
+    }
+    return $op->next;
+}
+
+sub pp_entersub {
+    my $op = shift;
+    write_back_lexicals(REGISTER|TEMPORARY);
+    write_back_stack();
+    my $sym = doop($op);
+    runtime("if (op != ($sym)->op_next) op = (*op->op_ppaddr)(ARGS);");
+    runtime("SPAGAIN;");
+    $know_op = 0;
+    invalidate_lexicals(REGISTER|TEMPORARY);
+    return $op->next;
+}
+
+sub pp_enterwrite {
+    my $op = shift;
+    pp_entersub($op);
+}
+
+sub pp_leavewrite {
+    my $op = shift;
+    write_back_lexicals(REGISTER|TEMPORARY);
+    write_back_stack();
+    my $sym = doop($op);
+    # XXX Is this the right way to distinguish between it returning
+    # CvSTART(cv) (via doform) and pop_return()?
+    runtime("if (op) op = (*op->op_ppaddr)(ARGS);");
+    runtime("SPAGAIN;");
+    $know_op = 0;
+    invalidate_lexicals(REGISTER|TEMPORARY);
+    return $op->next;
+}
+
+sub doeval {
+    my $op = shift;
+    $curcop->write_back;
+    write_back_lexicals(REGISTER|TEMPORARY);
+    write_back_stack();
+    my $sym = loadop($op);
+    my $ppaddr = $op->ppaddr;
+    runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
+    $know_op = 1;
+    invalidate_lexicals(REGISTER|TEMPORARY);
+    return $op->next;
+}
+
+sub pp_entereval { doeval(@_) }
+sub pp_require { doeval(@_) }
+sub pp_dofile { doeval(@_) }
+
+sub pp_entertry {
+    my $op = shift;
+    $curcop->write_back;
+    write_back_lexicals(REGISTER|TEMPORARY);
+    write_back_stack();
+    my $sym = doop($op);
+    my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++);
+    declare("Sigjmp_buf", $jmpbuf);
+    runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
+    invalidate_lexicals(REGISTER|TEMPORARY);
+    return $op->next;
+}
+
+sub pp_grepstart {
+    my $op = shift;
+    if ($need_freetmps && $freetmps_each_loop) {
+	runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up
+	$need_freetmps = 0;
+    }
+    write_back_stack();
+    doop($op);
+    return $op->next->other;
+}
+
+sub pp_mapstart {
+    my $op = shift;
+    if ($need_freetmps && $freetmps_each_loop) {
+	runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up
+	$need_freetmps = 0;
+    }
+    write_back_stack();
+    doop($op);
+    return $op->next->other;
+}
+
+sub pp_grepwhile {
+    my $op = shift;
+    my $next = $op->next;
+    unshift(@bblock_todo, $next);
+    write_back_lexicals();
+    write_back_stack();
+    my $sym = doop($op);
+    # pp_grepwhile can return either op_next or op_other and we need to
+    # be able to distinguish the two at runtime. Since it's possible for
+    # both ops to be "inlined", the fields could both be zero. To get
+    # around that, we hack op_next to be our own op (purely because we
+    # know it's a non-NULL pointer and can't be the same as op_other).
+    $init->add("((LOGOP*)$sym)->op_next = $sym;");
+    runtime(sprintf("if (op == ($sym)->op_next) goto %s;", label($next)));
+    $know_op = 0;
+    return $op->other;
+}
+
+sub pp_mapwhile {
+    pp_grepwhile(@_);
+}
+
+sub pp_return {
+    my $op = shift;
+    write_back_lexicals(REGISTER|TEMPORARY);
+    write_back_stack();
+    doop($op);
+    runtime("PUTBACK;", "return 0;");
+    $know_op = 0;
+    return $op->next;
+}
+
+sub nyi {
+    my $op = shift;
+    warn sprintf("%s not yet implemented properly\n", $op->ppaddr);
+    return default_pp($op);
+}
+
+sub pp_range {
+    my $op = shift;
+    my $flags = $op->flags;
+    if (!($flags & OPf_KNOW)) {
+	error("context of range unknown at compile-time");
+    }
+    write_back_lexicals();
+    write_back_stack();
+    if (!($flags & OPf_LIST)) {
+	# We need to save our UNOP structure since pp_flop uses
+	# it to find and adjust out targ. We don't need it ourselves.
+	$op->save;
+	runtime sprintf("if (SvTRUE(curpad[%d])) goto %s;",
+			$op->targ, label($op->false));
+	unshift(@bblock_todo, $op->false);
+    }
+    return $op->true;
+}
+
+sub pp_flip {
+    my $op = shift;
+    my $flags = $op->flags;
+    if (!($flags & OPf_KNOW)) {
+	error("context of flip unknown at compile-time");
+    }
+    if ($flags & OPf_LIST) {
+	return $op->first->false;
+    }
+    write_back_lexicals();
+    write_back_stack();
+    # We need to save our UNOP structure since pp_flop uses
+    # it to find and adjust out targ. We don't need it ourselves.
+    $op->save;
+    my $ix = $op->targ;
+    my $rangeix = $op->first->targ;
+    runtime(($op->private & OPpFLIP_LINENUM) ?
+	    "if (last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(last_in_gv))) {"
+	  : "if (SvTRUE(TOPs)) {");
+    runtime("\tsv_setiv(curpad[$rangeix], 1);");
+    if ($op->flags & OPf_SPECIAL) {
+	runtime("sv_setiv(curpad[$ix], 1);");
+    } else {
+	runtime("\tsv_setiv(curpad[$ix], 0);",
+		"\tsp--;",
+		sprintf("\tgoto %s;", label($op->first->false)));
+    }
+    runtime("}",
+	  qq{sv_setpv(curpad[$ix], "");},
+	    "SETs(curpad[$ix]);");
+    $know_op = 0;
+    return $op->next;
+}
+
+sub pp_flop {
+    my $op = shift;
+    default_pp($op);
+    $know_op = 0;
+    return $op->next;
+}
+
+sub enterloop {
+    my $op = shift;
+    my $nextop = $op->nextop;
+    my $lastop = $op->lastop;
+    my $redoop = $op->redoop;
+    $curcop->write_back;
+    debug "enterloop: pushing on cxstack" if $debug_cxstack;
+    push(@cxstack, {
+	type => CXt_LOOP,
+	op => $op,
+	"label" => $curcop->[0]->label,
+	nextop => $nextop,
+	lastop => $lastop,
+	redoop => $redoop
+    });
+    $nextop->save;
+    $lastop->save;
+    $redoop->save;
+    return default_pp($op);
+}
+
+sub pp_enterloop { enterloop(@_) }
+sub pp_enteriter { enterloop(@_) }
+
+sub pp_leaveloop {
+    my $op = shift;
+    if (!@cxstack) {
+	die "panic: leaveloop";
+    }
+    debug "leaveloop: popping from cxstack" if $debug_cxstack;
+    pop(@cxstack);
+    return default_pp($op);
+}
+
+sub pp_next {
+    my $op = shift;
+    my $cxix;
+    if ($op->flags & OPf_SPECIAL) {
+	$cxix = dopoptoloop();
+	if ($cxix < 0) {
+	    error('"next" used outside loop');
+	    return $op->next; # ignore the op
+	}
+    } else {
+	$cxix = dopoptolabel($op->pv);
+	if ($cxix < 0) {
+	    error('Label not found at compile time for "next %s"', $op->pv);
+	    return $op->next; # ignore the op
+	}
+    }
+    default_pp($op);
+    my $nextop = $cxstack[$cxix]->{nextop};
+    push(@bblock_todo, $nextop);
+    runtime(sprintf("goto %s;", label($nextop)));
+    return $op->next;
+}
+
+sub pp_redo {
+    my $op = shift;
+    my $cxix;
+    if ($op->flags & OPf_SPECIAL) {
+	$cxix = dopoptoloop();
+	if ($cxix < 0) {
+	    error('"redo" used outside loop');
+	    return $op->next; # ignore the op
+	}
+    } else {
+	$cxix = dopoptolabel($op->pv);
+	if ($cxix < 0) {
+	    error('Label not found at compile time for "redo %s"', $op->pv);
+	    return $op->next; # ignore the op
+	}
+    }
+    default_pp($op);
+    my $redoop = $cxstack[$cxix]->{redoop};
+    push(@bblock_todo, $redoop);
+    runtime(sprintf("goto %s;", label($redoop)));
+    return $op->next;
+}
+
+sub pp_last {
+    my $op = shift;
+    my $cxix;
+    if ($op->flags & OPf_SPECIAL) {
+	$cxix = dopoptoloop();
+	if ($cxix < 0) {
+	    error('"last" used outside loop');
+	    return $op->next; # ignore the op
+	}
+    } else {
+	$cxix = dopoptolabel($op->pv);
+	if ($cxix < 0) {
+	    error('Label not found at compile time for "last %s"', $op->pv);
+	    return $op->next; # ignore the op
+	}
+	# XXX Add support for "last" to leave non-loop blocks
+	if ($cxstack[$cxix]->{type} != CXt_LOOP) {
+	    error('Use of "last" for non-loop blocks is not yet implemented');
+	    return $op->next; # ignore the op
+	}
+    }
+    default_pp($op);
+    my $lastop = $cxstack[$cxix]->{lastop}->next;
+    push(@bblock_todo, $lastop);
+    runtime(sprintf("goto %s;", label($lastop)));
+    return $op->next;
+}
+
+sub pp_subst {
+    my $op = shift;
+    write_back_lexicals();
+    write_back_stack();
+    my $sym = doop($op);
+    my $replroot = $op->pmreplroot;
+    if ($$replroot) {
+	runtime sprintf("if (op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
+			$sym, label($replroot));
+	$op->pmreplstart->save;
+	push(@bblock_todo, $replroot);
+    }
+    invalidate_lexicals();
+    return $op->next;
+}
+
+sub pp_substcont {
+    my $op = shift;
+    write_back_lexicals();
+    write_back_stack();
+    doop($op);
+    my $pmop = $op->other;
+    warn sprintf("substcont: op = %s, pmop = %s\n",
+		 peekop($op), peekop($pmop));#debug
+#    my $pmopsym = objsym($pmop);
+    my $pmopsym = $pmop->save; # XXX can this recurse?
+    warn "pmopsym = $pmopsym\n";#debug
+    runtime sprintf("if (op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
+		    $pmopsym, label($pmop->pmreplstart));
+    invalidate_lexicals();
+    return $pmop->next;
+}
+
+sub default_pp {
+    my $op = shift;
+    my $ppname = $op->ppaddr;
+    write_back_lexicals() unless $skip_lexicals{$ppname};
+    write_back_stack() unless $skip_stack{$ppname};
+    doop($op);
+    # XXX If the only way that ops can write to a TEMPORARY lexical is
+    # when it's named in $op->targ then we could call
+    # invalidate_lexicals(TEMPORARY) and avoid having to write back all
+    # the temporaries. For now, we'll play it safe and write back the lot.
+    invalidate_lexicals() unless $skip_invalidate{$ppname};
+    return $op->next;
+}
+
+sub compile_op {
+    my $op = shift;
+    my $ppname = $op->ppaddr;
+    if (exists $ignore_op{$ppname}) {
+	return $op->next;
+    }
+    debug peek_stack() if $debug_stack;
+    if ($debug_op) {
+	debug sprintf("%s [%s]\n",
+		     peekop($op),
+		     $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ);
+    }
+    no strict 'refs';
+    if (defined(&$ppname)) {
+	$know_op = 0;
+	return &$ppname($op);
+    } else {
+	return default_pp($op);
+    }
+}
+
+sub compile_bblock {
+    my $op = shift;
+    #warn "compile_bblock: ", peekop($op), "\n"; # debug
+    write_label($op);
+    $know_op = 0;
+    do {
+	$op = compile_op($op);
+    } while (defined($op) && $$op && !exists($leaders->{$$op}));
+    write_back_stack(); # boo hoo: big loss
+    reload_lexicals();
+    return $op;
+}
+
+sub cc {
+    my ($name, $root, $start, @padlist) = @_;
+    my $op;
+    init_pp($name);
+    load_pad(@padlist);
+    B::Pseudoreg->new_scope;
+    @cxstack = ();
+    if ($debug_timings) {
+	warn sprintf("Basic block analysis at %s\n", timing_info);
+    }
+    $leaders = find_leaders($root, $start);
+    @bblock_todo = ($start, values %$leaders);
+    if ($debug_timings) {
+	warn sprintf("Compilation at %s\n", timing_info);
+    }
+    while (@bblock_todo) {
+	$op = shift @bblock_todo;
+	#warn sprintf("Considering basic block %s\n", peekop($op)); # debug
+	next if !defined($op) || !$$op || $done{$$op};
+	#warn "...compiling it\n"; # debug
+	do {
+	    $done{$$op} = 1;
+	    $op = compile_bblock($op);
+	    if ($need_freetmps && $freetmps_each_bblock) {
+		runtime("FREETMPS;");
+		$need_freetmps = 0;
+	    }
+	} while defined($op) && $$op && !$done{$$op};
+	if ($need_freetmps && $freetmps_each_loop) {
+	    runtime("FREETMPS;");
+	    $need_freetmps = 0;
+	}
+	if (!$$op) {
+	    runtime("PUTBACK;", "return 0;");
+	} elsif ($done{$$op}) {
+	    runtime(sprintf("goto %s;", label($op)));
+	}
+    }
+    if ($debug_timings) {
+	warn sprintf("Saving runtime at %s\n", timing_info);
+    }
+    save_runtime();
+}
+
+sub cc_recurse {
+    my $ccinfo;
+    my $start;
+    $start = cc_queue(@_) if @_;
+    while ($ccinfo = shift @cc_todo) {
+	cc(@$ccinfo);
+    }
+    return $start;
+}    
+
+sub cc_obj {
+    my ($name, $cvref) = @_;
+    my $cv = svref_2object($cvref);
+    my @padlist = $cv->PADLIST->ARRAY;
+    my $curpad_sym = $padlist[1]->save;
+    cc_recurse($name, $cv->ROOT, $cv->START, @padlist);
+}
+
+sub cc_main {
+    my @comppadlist = comppadlist->ARRAY;
+    my $curpad_sym = $comppadlist[1]->save;
+    my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
+    save_unused_subs(@unused_sub_packages);
+    cc_recurse();
+
+    return if $errors;
+    if (!defined($module)) {
+	$init->add(sprintf("main_root = s\\_%x;", ${main_root()}),
+		   "main_start = $start;",
+		   "curpad = AvARRAY($curpad_sym);");
+    }
+    output_boilerplate();
+    print "\n";
+    output_all("perl_init");
+    output_runtime();
+    print "\n";
+    output_main();
+    if (defined($module)) {
+	my $cmodule = $module;
+	$cmodule =~ s/::/__/g;
+	print <<"EOT";
+
+#include "XSUB.h"
+XS(boot_$cmodule)
+{
+    dXSARGS;
+    perl_init();
+    ENTER;
+    SAVETMPS;
+    SAVESPTR(curpad);
+    SAVESPTR(op);
+    curpad = AvARRAY($curpad_sym);
+    op = $start;
+    pp_main(ARGS);
+    FREETMPS;
+    LEAVE;
+    ST(0) = &sv_yes;
+    XSRETURN(1);
+}
+EOT
+    }
+    if ($debug_timings) {
+	warn sprintf("Done at %s\n", timing_info);
+    }
+}
+
+sub compile {
+    my @options = @_;
+    my ($option, $opt, $arg);
+  OPTION:
+    while ($option = shift @options) {
+	if ($option =~ /^-(.)(.*)/) {
+	    $opt = $1;
+	    $arg = $2;
+	} else {
+	    unshift @options, $option;
+	    last OPTION;
+	}
+	if ($opt eq "-" && $arg eq "-") {
+	    shift @options;
+	    last OPTION;
+	} elsif ($opt eq "o") {
+	    $arg ||= shift @options;
+	    open(STDOUT, ">$arg") or return "$arg: $!\n";
+	} elsif ($opt eq "n") {
+	    $arg ||= shift @options;
+	    $module_name = $arg;
+	} elsif ($opt eq "u") {
+	    $arg ||= shift @options;
+	    push(@unused_sub_packages, $arg);
+	} 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 >= 2) {
+		$freetmps_each_loop = 1;
+	    }
+	    if ($arg >= 1) {
+		$freetmps_each_bblock = 1 unless $freetmps_each_loop;
+	    }
+	} elsif ($opt eq "m") {
+	    $arg ||= shift @options;
+	    $module = $arg;
+	    push(@unused_sub_packages, $arg);
+	} elsif ($opt eq "p") {
+	    $arg ||= shift @options;
+	    $patchlevel = $arg;
+	} elsif ($opt eq "D") {
+            $arg ||= shift @options;
+	    foreach $arg (split(//, $arg)) {
+		if ($arg eq "o") {
+		    B->debug(1);
+		} elsif ($arg eq "O") {
+		    $debug_op = 1;
+		} elsif ($arg eq "s") {
+		    $debug_stack = 1;
+		} elsif ($arg eq "c") {
+		    $debug_cxstack = 1;
+		} elsif ($arg eq "p") {
+		    $debug_pad = 1;
+		} elsif ($arg eq "r") {
+		    $debug_runtime = 1;
+		} elsif ($arg eq "S") {
+		    $debug_shadow = 1;
+		} elsif ($arg eq "q") {
+		    $debug_queue = 1;
+		} elsif ($arg eq "l") {
+		    $debug_lineno = 1;
+		} elsif ($arg eq "t") {
+		    $debug_timings = 1;
+		}
+	    }
+	}
+    }
+    init_sections();
+    $init = B::Section->get("init");
+    $decl = B::Section->get("decl");
+
+    if (@options) {
+	return sub {
+	    my ($objname, $ppname);
+	    foreach $objname (@options) {
+		$objname = "main::$objname" unless $objname =~ /::/;
+		($ppname = $objname) =~ s/^.*?:://;
+		eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)";
+		die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@;
+		return if $errors;
+	    }
+	    output_boilerplate();
+	    print "\n";
+	    output_all($module_name || "init_module");
+	    output_runtime();
+	}
+    } else {
+	return sub { cc_main() };
+    }
+}
+
+1;
diff --git a/ext/B/B/Debug.pm b/ext/B/B/Debug.pm
new file mode 100644
index 0000000000..d88cef3780
--- /dev/null
+++ b/ext/B/B/Debug.pm
@@ -0,0 +1,263 @@
+package B::Debug;
+use strict;
+use B qw(peekop class walkoptree walkoptree_exec
+         main_start main_root cstring sv_undef);
+use B::Asmdata qw(@specialsv_name);
+
+my %done_gv;
+
+sub B::OP::debug {
+    my ($op) = @_;
+    printf <<'EOT', class($op), $$op, ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type, $op->seq, $op->flags, $op->private;
+%s (0x%lx)
+	op_next		0x%x
+	op_sibling	0x%x
+	op_ppaddr	%s
+	op_targ		%d
+	op_type		%d
+	op_seq		%d
+	op_flags	%d
+	op_private	%d
+EOT
+}
+
+sub B::UNOP::debug {
+    my ($op) = @_;
+    $op->B::OP::debug();
+    printf "\top_first\t0x%x\n", ${$op->first};
+}
+
+sub B::BINOP::debug {
+    my ($op) = @_;
+    $op->B::UNOP::debug();
+    printf "\top_last\t\t0x%x\n", ${$op->last};
+}
+
+sub B::LOGOP::debug {
+    my ($op) = @_;
+    $op->B::UNOP::debug();
+    printf "\top_other\t0x%x\n", ${$op->other};
+}
+
+sub B::CONDOP::debug {
+    my ($op) = @_;
+    $op->B::UNOP::debug();
+    printf "\top_true\t0x%x\n", ${$op->true};
+    printf "\top_false\t0x%x\n", ${$op->false};
+}
+
+sub B::LISTOP::debug {
+    my ($op) = @_;
+    $op->B::BINOP::debug();
+    printf "\top_children\t%d\n", $op->children;
+}
+
+sub B::PMOP::debug {
+    my ($op) = @_;
+    $op->B::LISTOP::debug();
+    printf "\top_pmreplroot\t0x%x\n", ${$op->pmreplroot};
+    printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
+    printf "\top_pmnext\t0x%x\n", ${$op->pmnext};
+    printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp);
+    printf "\top_pmflags\t0x%x\n", $op->pmflags;
+    $op->pmshort->debug;
+    $op->pmreplroot->debug;
+}
+
+sub B::COP::debug {
+    my ($op) = @_;
+    $op->B::OP::debug();
+    my ($filegv) = $op->filegv;
+    printf <<'EOT', $op->label, ${$op->stash}, $$filegv, $op->seq, $op->arybase, $op->line;
+	cop_label	%s
+	cop_stash	0x%x
+	cop_filegv	0x%x
+	cop_seq		%d
+	cop_arybase	%d
+	cop_line	%d
+EOT
+    $filegv->debug;
+}
+
+sub B::SVOP::debug {
+    my ($op) = @_;
+    $op->B::OP::debug();
+    printf "\top_sv\t\t0x%x\n", ${$op->sv};
+    $op->sv->debug;
+}
+
+sub B::PVOP::debug {
+    my ($op) = @_;
+    $op->B::OP::debug();
+    printf "\top_pv\t\t0x%x\n", $op->pv;
+}
+
+sub B::GVOP::debug {
+    my ($op) = @_;
+    $op->B::OP::debug();
+    printf "\top_gv\t\t0x%x\n", ${$op->gv};
+    $op->gv->debug;
+}
+
+sub B::CVOP::debug {
+    my ($op) = @_;
+    $op->B::OP::debug();
+    printf "\top_cv\t\t0x%x\n", ${$op->cv};
+}
+
+sub B::NULL::debug {
+    my ($sv) = @_;
+    if ($$sv == ${sv_undef()}) {
+	print "&sv_undef\n";
+    } else {
+	printf "NULL (0x%x)\n", $$sv;
+    }
+}
+
+sub B::SV::debug {
+    my ($sv) = @_;
+    if (!$$sv) {
+	print class($sv), " = NULL\n";
+	return;
+    }
+    printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS;
+%s (0x%x)
+	REFCNT		%d
+	FLAGS		0x%x
+EOT
+}
+
+sub B::PV::debug {
+    my ($sv) = @_;
+    $sv->B::SV::debug();
+    my $pv = $sv->PV();
+    printf <<'EOT', cstring($pv), length($pv);
+	xpv_pv		%s
+	xpv_cur		%d
+EOT
+}
+
+sub B::IV::debug {
+    my ($sv) = @_;
+    $sv->B::SV::debug();
+    printf "\txiv_iv\t\t%d\n", $sv->IV;
+}
+
+sub B::NV::debug {
+    my ($sv) = @_;
+    $sv->B::IV::debug();
+    printf "\txnv_nv\t\t%s\n", $sv->NV;
+}
+
+sub B::PVIV::debug {
+    my ($sv) = @_;
+    $sv->B::PV::debug();
+    printf "\txiv_iv\t\t%d\n", $sv->IV;
+}
+
+sub B::PVNV::debug {
+    my ($sv) = @_;
+    $sv->B::PVIV::debug();
+    printf "\txnv_nv\t\t%s\n", $sv->NV;
+}
+
+sub B::PVLV::debug {
+    my ($sv) = @_;
+    $sv->B::PVNV::debug();
+    printf "\txlv_targoff\t%d\n", $sv->TARGOFF;
+    printf "\txlv_targlen\t%u\n", $sv->TARGLEN;
+    printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE));
+}
+
+sub B::BM::debug {
+    my ($sv) = @_;
+    $sv->B::PVNV::debug();
+    printf "\txbm_useful\t%d\n", $sv->USEFUL;
+    printf "\txbm_previous\t%u\n", $sv->PREVIOUS;
+    printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE));
+}
+
+sub B::CV::debug {
+    my ($sv) = @_;
+    $sv->B::PVNV::debug();
+    my ($stash) = $sv->STASH;
+    my ($start) = $sv->START;
+    my ($root) = $sv->ROOT;
+    my ($padlist) = $sv->PADLIST;
+    my ($gv) = $sv->GV;
+    my ($filegv) = $sv->FILEGV;
+    printf <<'EOT', $$stash, $$start, $$root, $$gv, $$filegv, $sv->DEPTH, $padlist, ${$sv->OUTSIDE};
+	STASH		0x%x
+	START		0x%x
+	ROOT		0x%x
+	GV		0x%x
+	FILEGV		0x%x
+	DEPTH		%d
+	PADLIST		0x%x			       
+	OUTSIDE		0x%x
+EOT
+    $start->debug if $start;
+    $root->debug if $root;
+    $gv->debug if $gv;
+    $filegv->debug if $filegv;
+    $padlist->debug if $padlist;
+}
+
+sub B::AV::debug {
+    my ($av) = @_;
+    $av->B::SV::debug;
+    my(@array) = $av->ARRAY;
+    print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
+    printf <<'EOT', scalar(@array), $av->MAX, $av->OFF, $av->AvFLAGS;
+	FILL		%d    
+	MAX		%d
+	OFF		%d
+	AvFLAGS		%d
+EOT
+}
+    
+sub B::GV::debug {
+    my ($gv) = @_;
+    if ($done_gv{$$gv}++) {
+	printf "GV %s::%s\n", $gv->STASH->NAME, $gv->NAME;
+	return;
+    }
+    my ($sv) = $gv->SV;
+    my ($av) = $gv->AV;
+    my ($cv) = $gv->CV;
+    $gv->B::SV::debug;
+    printf <<'EOT', $gv->NAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILEGV, $gv->GvFLAGS;
+	NAME		%s
+	STASH		%s (0x%x)
+	SV		0x%x
+	GvREFCNT	%d
+	FORM		0x%x
+	AV		0x%x
+	HV		0x%x
+	EGV		0x%x
+	CV		0x%x
+	CVGEN		%d
+	LINE		%d
+	FILEGV		0x%x
+	GvFLAGS		0x%x
+EOT
+    $sv->debug if $sv;
+    $av->debug if $av;
+    $cv->debug if $cv;
+}
+
+sub B::SPECIAL::debug {
+    my $sv = shift;
+    print $specialsv_name[$$sv], "\n";
+}
+
+sub compile {
+    my $order = shift;
+    if ($order eq "exec") {
+        return sub { walkoptree_exec(main_start, "debug") }
+    } else {
+        return sub { walkoptree(main_root, "debug") }
+    }
+}
+
+1;
diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm
new file mode 100644
index 0000000000..9802cb4350
--- /dev/null
+++ b/ext/B/B/Deparse.pm
@@ -0,0 +1,102 @@
+package B::Deparse;
+use strict;
+use B qw(peekop class main_root);
+
+my $debug;
+
+sub compile {
+    my $opt = shift;
+    if ($opt eq "-d") {
+	$debug = 1;
+    }
+    return sub { print deparse(main_root), "\n" }
+}
+
+sub ppname {
+    my $op = shift;
+    my $ppname = $op->ppaddr;
+    warn sprintf("ppname %s\n", peekop($op)) if $debug;
+    no strict "refs";
+    return defined(&$ppname) ? &$ppname($op) : 0;
+}
+
+sub deparse {
+    my $op = shift;
+    my $expr;
+    warn sprintf("deparse %s\n", peekop($op)) if $debug;
+    while (ref($expr = ppname($op))) {
+	$op = $expr;
+	warn sprintf("Redirecting to %s\n", peekop($op)) if $debug;
+    }
+    return $expr;
+}
+
+sub pp_leave {
+    my $op = shift;
+    my ($child, $expr);
+    for ($child = $op->first; !$expr; $child = $child->sibling) {
+	$expr = ppname($child);
+    }
+    return $expr;
+}
+
+sub SWAP_CHILDREN () { 1 }
+
+sub binop {
+    my ($op, $opname, $flags) = @_;
+    my $left = $op->first;
+    my $right = $op->last;
+    if ($flags & SWAP_CHILDREN) {
+	($left, $right) = ($right, $left);
+    }
+    warn sprintf("binop deparsing first %s\n", peekop($op->first)) if $debug;
+    $left = deparse($left);
+    warn sprintf("binop deparsing last %s\n", peekop($op->last)) if $debug;
+    $right = deparse($right);
+    return "($left $opname $right)";
+}
+
+sub pp_add { binop($_[0], "+") }
+sub pp_multiply { binop($_[0], "*") }
+sub pp_subtract { binop($_[0], "-") }
+sub pp_divide { binop($_[0], "/") }
+sub pp_modulo { binop($_[0], "%") }
+sub pp_eq { binop($_[0], "==") }
+sub pp_ne { binop($_[0], "!=") }
+sub pp_lt { binop($_[0], "<") }
+sub pp_gt { binop($_[0], ">") }
+sub pp_ge { binop($_[0], ">=") }
+
+sub pp_sassign { binop($_[0], "=", SWAP_CHILDREN) }
+
+sub pp_null {
+    my $op = shift;
+    warn sprintf("Skipping null op %s\n", peekop($op)) if $debug;
+    return $op->first;
+}
+
+sub pp_const {
+    my $op = shift;
+    my $sv = $op->sv;
+    if (class($sv) eq "IV") {
+	return $sv->IV;
+    } elsif (class($sv) eq "NV") {
+	return $sv->NV;
+    } else {
+	return $sv->PV;
+    }
+}
+
+sub pp_gvsv {
+    my $op = shift;
+    my $gv = $op->gv;
+    my $stash = $gv->STASH->NAME;
+    if ($stash eq "main") {
+	$stash = "";
+    } else {
+	$stash = $stash . "::";
+    }
+    return sprintf('$%s%s', $stash, $gv->NAME);
+}
+
+1;
diff --git a/ext/B/B/Disassembler.pm b/ext/B/B/Disassembler.pm
new file mode 100644
index 0000000000..36db354849
--- /dev/null
+++ b/ext/B/B/Disassembler.pm
@@ -0,0 +1,144 @@
+#      Disassembler.pm
+#
+#      Copyright (c) 1996 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.
+package B::Disassembler::BytecodeStream;
+use FileHandle;
+use Carp;
+use B qw(cstring cast_I32);
+@ISA = qw(FileHandle);
+sub readn {
+    my ($fh, $len) = @_;
+    my $data;
+    read($fh, $data, $len);
+    croak "reached EOF while reading $len bytes" unless length($data) == $len;
+    return $data;
+}
+
+sub GET_U8 {
+    my $fh = shift;
+    my $c = $fh->getc;
+    croak "reached EOF while reading U8" unless defined($c);
+    return ord($c);
+}
+
+sub GET_U16 {
+    my $fh = shift;
+    my $str = $fh->readn(2);
+    croak "reached EOF while reading U16" unless length($str) == 2;
+    return unpack("n", $str);
+}
+
+sub GET_U32 {
+    my $fh = shift;
+    my $str = $fh->readn(4);
+    croak "reached EOF while reading U32" unless length($str) == 4;
+    return unpack("N", $str);
+}
+
+sub GET_I32 {
+    my $fh = shift;
+    my $str = $fh->readn(4);
+    croak "reached EOF while reading I32" unless length($str) == 4;
+    return cast_I32(unpack("N", $str));
+}
+
+sub GET_objindex { 
+    my $fh = shift;
+    my $str = $fh->readn(4);
+    croak "reached EOF while reading objindex" unless length($str) == 4;
+    return unpack("N", $str);
+}
+
+sub GET_strconst {
+    my $fh = shift;
+    my ($str, $c);
+    while (defined($c = $fh->getc) && $c ne "\0") {
+	$str .= $c;
+    }
+    croak "reached EOF while reading strconst" unless defined($c);
+    return cstring($str);
+}
+
+sub GET_pvcontents {}
+
+sub GET_PV {
+    my $fh = shift;
+    my $str;
+    my $len = $fh->GET_U32;
+    if ($len) {
+	read($fh, $str, $len);
+	croak "reached EOF while reading PV" unless length($str) == $len;
+	return cstring($str);
+    } else {
+	return '""';
+    }
+}
+
+sub GET_comment {
+    my $fh = shift;
+    my ($str, $c);
+    while (defined($c = $fh->getc) && $c ne "\n") {
+	$str .= $c;
+    }
+    croak "reached EOF while reading comment" unless defined($c);
+    return cstring($str);
+}
+
+sub GET_double {
+    my $fh = shift;
+    my ($str, $c);
+    while (defined($c = $fh->getc) && $c ne "\0") {
+	$str .= $c;
+    }
+    croak "reached EOF while reading double" unless defined($c);
+    return $str;
+}
+
+sub GET_none {}
+
+sub GET_op_tr_array {
+    my $fh = shift;
+    my @ary = unpack("n256", $fh->readn(256 * 2));
+    return join(",", @ary);
+}
+
+sub GET_IV64 {
+    my $fh = shift;
+    my ($hi, $lo) = unpack("NN", $fh->readn(8));
+    return sprintf("0x%4x%04x", $hi, $lo); # cheat
+}
+
+package B::Disassembler;
+use Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(disassemble_fh);
+use Carp;
+use strict;
+
+use B::Asmdata qw(%insn_data @insn_name);
+
+sub disassemble_fh {
+    my ($fh, $out) = @_;
+    my ($c, $getmeth, $insn, $arg);
+    bless $fh, "B::Disassembler::BytecodeStream";
+    while (defined($c = $fh->getc)) {
+	$c = ord($c);
+	$insn = $insn_name[$c];
+	if (!defined($insn) || $insn eq "unused") {
+	    my $pos = $fh->tell - 1;
+	    die "Illegal instruction code $c at stream offset $pos\n";
+	}
+	$getmeth = $insn_data{$insn}->[2];
+	$arg = $fh->$getmeth();
+	if (defined($arg)) {
+	    &$out($insn, $arg);
+	} else {
+	    &$out($insn);
+	}
+    }
+}
+
+1;
diff --git a/ext/B/B/Lint.pm b/ext/B/B/Lint.pm
new file mode 100644
index 0000000000..d34bd7792b
--- /dev/null
+++ b/ext/B/B/Lint.pm
@@ -0,0 +1,367 @@
+package B::Lint;
+
+=head1 NAME
+
+B::Lint - Perl lint
+
+=head1 SYNOPSIS
+
+perl -MO=Lint[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+The B::Lint module is equivalent to an extended version of the B<-w>
+option of B<perl>. It is named after the program B<lint> which carries
+out a similar process for C programs.
+
+=head1 OPTIONS AND LINT CHECKS
+
+Option words are separated by commas (not whitespace) and follow the
+usual conventions of compiler backend options. Following any options
+(indicated by a leading B<->) come lint check arguments. Each such
+argument (apart from the special B<all> and B<none> options) is a
+word representing one possible lint check (turning on that check) or
+is B<no-foo> (turning off that check). Before processing the check
+arguments, a standard list of checks is turned on. Later options
+override earlier ones. Available options are:
+
+=over 8
+
+=item B<context>
+
+Produces a warning whenever an array is used in an implicit scalar
+context. For example, both of the lines
+
+    $foo = length(@bar);
+    $foo = @bar;
+will elicit a warning. Using an explicit B<scalar()> silences the
+warning. For example,
+
+    $foo = scalar(@bar);
+
+=item B<implicit-read> and B<implicit-write>
+
+These options produce a warning whenever an operation implicitly
+reads or (respectively) writes to one of Perl's special variables.
+For example, B<implicit-read> will warn about these:
+
+    /foo/;
+
+and B<implicit-write> will warn about these:
+
+    s/foo/bar/;
+
+Both B<implicit-read> and B<implicit-write> warn about this:
+
+    for (@a) { ... }
+
+=item B<dollar-underscore>
+
+This option warns whenever $_ is used either explicitly anywhere or
+as the implicit argument of a B<print> statement.
+
+=item B<private-names>
+
+This option warns on each use of any variable, subroutine or
+method name that lives in a non-current package but begins with
+an underscore ("_"). Warnings aren't issued for the special case
+of the single character name "_" by itself (e.g. $_ and @_).
+
+=item B<undefined-subs>
+
+This option warns whenever an undefined subroutine is invoked.
+This option will only catch explicitly invoked subroutines such
+as C<foo()> and not indirect invocations such as C<&$subref()>
+or C<$obj-E<gt>meth()>. Note that some programs or modules delay
+definition of subs until runtime by means of the AUTOLOAD
+mechanism.
+
+=item B<regexp-variables>
+
+This option warns whenever one of the regexp variables $', $& or
+$' is used. Any occurrence of any of these variables in your
+program can slow your whole program down. See L<perlre> for
+details.
+
+=item B<all>
+
+Turn all warnings on.
+
+=item B<none>
+
+Turn all warnings off.
+
+=back
+
+=head1 NON LINT-CHECK OPTIONS
+
+=over 8
+
+=item B<-u Package>
+
+Normally, Lint only checks the main code of the program together
+with all subs defined in package main. The B<-u> option lets you
+include other package names whose subs are then checked by Lint.
+
+=back
+
+=head1 BUGS
+
+This is only a very preliminary version.
+
+=head1 AUTHOR
+
+Malcolm Beattie, mbeattie@sable.ox.ac.uk.
+
+=cut
+
+use strict;
+use B qw(walkoptree_slow main_root walksymtable svref_2object parents);
+
+# Constants (should probably be elsewhere)
+sub G_ARRAY () { 1 }
+sub OPf_LIST () { 1 }
+sub OPf_KNOW () { 2 }
+sub OPf_STACKED () { 64 }
+
+my $file = "unknown";		# shadows current filename
+my $line = 0;			# shadows current line number
+my $curstash = "main";		# shadows current stash
+
+# Lint checks
+my %check;
+my %implies_ok_context;
+BEGIN {
+    map($implies_ok_context{$_}++,
+	qw(pp_scalar pp_av2arylen pp_aelem pp_aslice pp_helem pp_hslice
+	   pp_keys pp_values pp_hslice pp_defined pp_undef pp_delete));
+}
+
+# Lint checks turned on by default
+my @default_checks = qw(context);
+
+my %valid_check;
+# All valid checks
+BEGIN {
+    map($valid_check{$_}++,
+	qw(context implicit_read implicit_write dollar_underscore
+	   private_names undefined_subs regexp_variables));
+}
+
+# Debugging options
+my ($debug_op);
+
+my %done_cv;		# used to mark which subs have already been linted
+my @extra_packages;	# Lint checks mainline code and all subs which are
+			# in main:: or in one of these packages.
+
+sub warning {
+    my $format = (@_ < 2) ? "%s" : shift;
+    warn sprintf("$format at %s line %d\n", @_, $file, $line);
+}
+
+# This gimme can't cope with context that's only determined
+# at runtime via dowantarray().
+sub gimme {
+    my $op = shift;
+    my $flags = $op->flags;
+    if ($flags & OPf_KNOW) {
+	return(($flags & OPf_LIST) ? 1 : 0);
+    }
+    return undef;
+}
+
+sub B::OP::lint {}
+
+sub B::COP::lint {
+    my $op = shift;
+    if ($op->ppaddr eq "pp_nextstate") {
+	$file = $op->filegv->SV->PV;
+	$line = $op->line;
+	$curstash = $op->stash->NAME;
+    }
+}
+
+sub B::UNOP::lint {
+    my $op = shift;
+    my $ppaddr = $op->ppaddr;
+    if ($check{context} && ($ppaddr eq "pp_rv2av" || $ppaddr eq "pp_rv2hv")) {
+	my $parent = parents->[0];
+	my $pname = $parent->ppaddr;
+	return if gimme($op) || $implies_ok_context{$pname};
+	# Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}"
+	# null out the parent so we have to check for a parent of pp_null and
+	# a grandparent of pp_enteriter or pp_delete
+	if ($pname eq "pp_null") {
+	    my $gpname = parents->[1]->ppaddr;
+	    return if $gpname eq "pp_enteriter" || $gpname eq "pp_delete";
+	}
+	warning("Implicit scalar context for %s in %s",
+		$ppaddr eq "pp_rv2av" ? "array" : "hash", $parent->desc);
+    }
+    if ($check{private_names} && $ppaddr eq "pp_method") {
+	my $methop = $op->first;
+	if ($methop->ppaddr eq "pp_const") {
+	    my $method = $methop->sv->PV;
+	    if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) {
+		warning("Illegal reference to private method name $method");
+	    }
+	}
+    }
+}
+
+sub B::PMOP::lint {
+    my $op = shift;
+    if ($check{implicit_read}) {
+	my $ppaddr = $op->ppaddr;
+	if ($ppaddr eq "pp_match" && !($op->flags & OPf_STACKED)) {
+	    warning('Implicit match on $_');
+	}
+    }
+    if ($check{implicit_write}) {
+	my $ppaddr = $op->ppaddr;
+	if ($ppaddr eq "pp_subst" && !($op->flags & OPf_STACKED)) {
+	    warning('Implicit substitution on $_');
+	}
+    }
+}
+
+sub B::LOOP::lint {
+    my $op = shift;
+    if ($check{implicit_read} || $check{implicit_write}) {
+	my $ppaddr = $op->ppaddr;
+	if ($ppaddr eq "pp_enteriter") {
+	    my $last = $op->last;
+	    if ($last->ppaddr eq "pp_gv" && $last->gv->NAME eq "_") {
+		warning('Implicit use of $_ in foreach');
+	    }
+	}
+    }
+}
+
+sub B::GVOP::lint {
+    my $op = shift;
+    if ($check{dollar_underscore} && $op->ppaddr eq "pp_gvsv"
+	&& $op->gv->NAME eq "_")
+    {
+	warning('Use of $_');
+    }
+    if ($check{private_names}) {
+	my $ppaddr = $op->ppaddr;
+	my $gv = $op->gv;
+	if (($ppaddr eq "pp_gv" || $ppaddr eq "pp_gvsv")
+	    && $gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash)
+	{
+	    warning('Illegal reference to private name %s', $gv->NAME);
+	}
+    }
+    if ($check{undefined_subs}) {
+	if ($op->ppaddr eq "pp_gv" && $op->next->ppaddr eq "pp_entersub") {
+	    my $gv = $op->gv;
+	    my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
+	    no strict 'refs';
+	    if (!defined(&$subname)) {
+		$subname =~ s/^main:://;
+		warning('Undefined subroutine %s called', $subname);
+	    }
+	}
+    }
+    if ($check{regexp_variables} && $op->ppaddr eq "pp_gvsv") {
+	my $name = $op->gv->NAME;
+	if ($name =~ /^[&'`]$/) {
+	    warning('Use of regexp variable $%s', $name);
+	}
+    }
+}
+
+sub B::GV::lintcv {
+    my $gv = shift;
+    my $cv = $gv->CV;
+    #warn sprintf("lintcv: %s::%s (done=%d)\n",
+    #		 $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug
+    return if !$$cv || $done_cv{$$cv}++;
+    my $root = $cv->ROOT;
+    #warn "    root = $root (0x$$root)\n";#debug
+    walkoptree_slow($root, "lint") if $$root;
+}
+
+sub do_lint {
+    my %search_pack;
+    walkoptree_slow(main_root, "lint") if ${main_root()};
+    
+    # Now do subs in main
+    no strict qw(vars refs);
+    my $sym;
+    local(*glob);
+    while (($sym, *glob) = each %{"main::"}) {
+	#warn "Trying $sym\n";#debug
+	svref_2object(\*glob)->EGV->lintcv unless $sym =~ /::$/;
+    }
+
+    # Now do subs in non-main packages given by -u options
+    map { $search_pack{$_} = 1 } @extra_packages;
+    walksymtable(\%{"main::"}, "lintcv", sub {
+	my $package = shift;
+	$package =~ s/::$//;
+	#warn "Considering $package\n";#debug
+	return exists $search_pack{$package};
+    });
+}
+
+sub compile {
+    my @options = @_;
+    my ($option, $opt, $arg);
+    # Turn on default lint checks
+    for $opt (@default_checks) {
+	$check{$opt} = 1;
+    }
+  OPTION:
+    while ($option = shift @options) {
+	if ($option =~ /^-(.)(.*)/) {
+	    $opt = $1;
+	    $arg = $2;
+	} else {
+	    unshift @options, $option;
+	    last OPTION;
+	}
+	if ($opt eq "-" && $arg eq "-") {
+	    shift @options;
+	    last OPTION;
+	} elsif ($opt eq "D") {
+            $arg ||= shift @options;
+	    foreach $arg (split(//, $arg)) {
+		if ($arg eq "o") {
+		    B->debug(1);
+		} elsif ($arg eq "O") {
+		    $debug_op = 1;
+		}
+	    }
+	} elsif ($opt eq "u") {
+	    $arg ||= shift @options;
+	    push(@extra_packages, $arg);
+	}
+    }
+    foreach $opt (@default_checks, @options) {
+	$opt =~ tr/-/_/;
+	if ($opt eq "all") {
+	    %check = %valid_check;
+	}
+	elsif ($opt eq "none") {
+	    %check = ();
+	}
+	else {
+	    if ($opt =~ s/^no-//) {
+		$check{$opt} = 0;
+	    }
+	    else {
+		$check{$opt} = 1;
+	    }
+	    warn "No such check: $opt\n" unless defined $valid_check{$opt};
+	}
+    }
+    # Remaining arguments are things to check
+    
+    return \&do_lint;
+}
+
+1;
diff --git a/ext/B/B/Showlex.pm b/ext/B/B/Showlex.pm
new file mode 100644
index 0000000000..9cf8ecc564
--- /dev/null
+++ b/ext/B/B/Showlex.pm
@@ -0,0 +1,58 @@
+package B::Showlex;
+use strict;
+use B qw(svref_2object comppadlist class);
+use B::Terse ();
+
+#
+# Invoke as
+#     perl -MO=Showlex,foo bar.pl
+# to see the names of lexical variables used by &foo
+# or as
+#     perl -MO=Showlex bar.pl
+# to see the names of file scope lexicals used by bar.pl
+#    
+
+sub showarray {
+    my ($name, $av) = @_;
+    my @els = $av->ARRAY;
+    my $count = @els;
+    my $i;
+    print "$name has $count entries\n";
+    for ($i = 0; $i < $count; $i++) {
+	print "$i: ";
+	$els[$i]->terse;
+    }
+}
+
+sub showlex {
+    my ($objname, $namesav, $valsav) = @_;
+    showarray("Pad of lexical names for $objname", $namesav);
+    showarray("Pad of lexical values for $objname", $valsav);
+}
+
+sub showlex_obj {
+    my ($objname, $obj) = @_;
+    $objname =~ s/^&main::/&/;
+    showlex($objname, svref_2object($obj)->PADLIST->ARRAY);
+}
+
+sub showlex_main {
+    showlex("comppadlist", comppadlist->ARRAY);
+}
+
+sub compile {
+    my @options = @_;
+    if (@options) {
+	return sub {
+	    my $objname;
+	    foreach $objname (@options) {
+		$objname = "main::$objname" unless $objname =~ /::/;
+		eval "showlex_obj('&$objname', \\&$objname)";
+	    }
+	}
+    } else {
+	return \&showlex_main;
+    }
+}
+
+1;
diff --git a/ext/B/B/Stackobj.pm b/ext/B/B/Stackobj.pm
new file mode 100644
index 0000000000..8be047f19f
--- /dev/null
+++ b/ext/B/B/Stackobj.pm
@@ -0,0 +1,281 @@
+#      Stackobj.pm
+#
+#      Copyright (c) 1996 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.
+#
+package B::Stackobj;
+use Exporter ();
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT
+		VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY);
+%EXPORT_TAGS = (types => [qw(T_UNKNOWN T_DOUBLE T_INT)],
+		flags => [qw(VALID_INT VALID_DOUBLE VALID_SV
+			     REGISTER TEMPORARY)]);
+
+use Carp qw(confess);
+use strict;
+use B qw(class);
+
+# Perl internal constants that I should probably define elsewhere.
+sub SVf_IOK () { 0x10000 }
+sub SVf_NOK () { 0x20000 }
+
+# Types
+sub T_UNKNOWN () { 0 }
+sub T_DOUBLE ()  { 1 }
+sub T_INT ()     { 2 }
+
+# Flags
+sub VALID_INT ()	{ 0x01 }
+sub VALID_DOUBLE ()	{ 0x02 }
+sub VALID_SV ()		{ 0x04 }
+sub REGISTER ()		{ 0x08 } # no implicit write-back when calling subs
+sub TEMPORARY ()	{ 0x10 } # no implicit write-back needed at all
+
+#
+# Callback for runtime code generation
+#
+my $runtime_callback = sub { confess "set_callback not yet called" };
+sub set_callback (&) { $runtime_callback = shift }
+sub runtime { &$runtime_callback(@_) }
+
+#
+# Methods
+#
+
+sub write_back { confess "stack object does not implement write_back" }
+
+sub invalidate { shift->{flags} &= ~(VALID_INT | VALID_DOUBLE) }
+
+sub as_sv {
+    my $obj = shift;
+    if (!($obj->{flags} & VALID_SV)) {
+	$obj->write_back;
+	$obj->{flags} |= VALID_SV;
+    }
+    return $obj->{sv};
+}
+
+sub as_int {
+    my $obj = shift;
+    if (!($obj->{flags} & VALID_INT)) {
+	$obj->load_int;
+	$obj->{flags} |= VALID_INT;
+    }
+    return $obj->{iv};
+}
+
+sub as_double {
+    my $obj = shift;
+    if (!($obj->{flags} & VALID_DOUBLE)) {
+	$obj->load_double;
+	$obj->{flags} |= VALID_DOUBLE;
+    }
+    return $obj->{nv};
+}
+
+sub as_numeric {
+    my $obj = shift;
+    return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double;
+}
+
+#
+# Debugging methods
+#
+sub peek {
+    my $obj = shift;
+    my $type = $obj->{type};
+    my $flags = $obj->{flags};
+    my @flags;
+    if ($type == T_UNKNOWN) {
+	$type = "T_UNKNOWN";
+    } elsif ($type == T_INT) {
+	$type = "T_INT";
+    } elsif ($type == T_DOUBLE) {
+	$type = "T_DOUBLE";
+    } else {
+	$type = "(illegal type $type)";
+    }
+    push(@flags, "VALID_INT") if $flags & VALID_INT;
+    push(@flags, "VALID_DOUBLE") if $flags & VALID_DOUBLE;
+    push(@flags, "VALID_SV") if $flags & VALID_SV;
+    push(@flags, "REGISTER") if $flags & REGISTER;
+    push(@flags, "TEMPORARY") if $flags & TEMPORARY;
+    @flags = ("none") unless @flags;
+    return sprintf("%s type=$type flags=%s sv=$obj->{sv}",
+		   class($obj), join("|", @flags));
+}
+
+sub minipeek {
+    my $obj = shift;
+    my $type = $obj->{type};
+    my $flags = $obj->{flags};
+    if ($type == T_INT || $flags & VALID_INT) {
+	return $obj->{iv};
+    } elsif ($type == T_DOUBLE || $flags & VALID_DOUBLE) {
+	return $obj->{nv};
+    } else {
+	return $obj->{sv};
+    }
+}
+
+#
+# Caller needs to ensure that set_int, set_double,
+# set_numeric and set_sv are only invoked on legal lvalues.
+#
+sub set_int {
+    my ($obj, $expr) = @_;
+    runtime("$obj->{iv} = $expr;");
+    $obj->{flags} &= ~(VALID_SV | VALID_DOUBLE);
+    $obj->{flags} |= VALID_INT;
+}
+
+sub set_double {
+    my ($obj, $expr) = @_;
+    runtime("$obj->{nv} = $expr;");
+    $obj->{flags} &= ~(VALID_SV | VALID_INT);
+    $obj->{flags} |= VALID_DOUBLE;
+}
+
+sub set_numeric {
+    my ($obj, $expr) = @_;
+    if ($obj->{type} == T_INT) {
+	$obj->set_int($expr);
+    } else {
+	$obj->set_double($expr);
+    }
+}
+
+sub set_sv {
+    my ($obj, $expr) = @_;
+    runtime("SvSetSV($obj->{sv}, $expr);");
+    $obj->invalidate;
+    $obj->{flags} |= VALID_SV;
+}
+
+#
+# Stackobj::Padsv
+#
+
+@B::Stackobj::Padsv::ISA = 'B::Stackobj';
+sub B::Stackobj::Padsv::new {
+    my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_;
+    bless {
+	type => $type,
+	flags => VALID_SV | $extra_flags,
+	sv => "curpad[$ix]",
+	iv => "$iname",
+	nv => "$dname"
+    }, $class;
+}
+
+sub B::Stackobj::Padsv::load_int {
+    my $obj = shift;
+    if ($obj->{flags} & VALID_DOUBLE) {
+	runtime("$obj->{iv} = $obj->{nv};");
+    } else {
+	runtime("$obj->{iv} = SvIV($obj->{sv});");
+    }
+    $obj->{flags} |= VALID_INT;
+}
+
+sub B::Stackobj::Padsv::load_double {
+    my $obj = shift;
+    $obj->write_back;
+    runtime("$obj->{nv} = SvNV($obj->{sv});");
+    $obj->{flags} |= VALID_DOUBLE;
+}
+
+sub B::Stackobj::Padsv::write_back {
+    my $obj = shift;
+    my $flags = $obj->{flags};
+    return if $flags & VALID_SV;
+    if ($flags & VALID_INT) {
+	runtime("sv_setiv($obj->{sv}, $obj->{iv});");
+    } elsif ($flags & VALID_DOUBLE) {
+	runtime("sv_setnv($obj->{sv}, $obj->{nv});");
+    } else {
+	confess "write_back failed for lexical @{[$obj->peek]}\n";
+    }
+    $obj->{flags} |= VALID_SV;
+}
+
+#
+# Stackobj::Const
+#
+
+@B::Stackobj::Const::ISA = 'B::Stackobj';
+sub B::Stackobj::Const::new {
+    my ($class, $sv) = @_;
+    my $obj = bless {
+	flags => 0,
+	sv => $sv    # holds the SV object until write_back happens
+    }, $class;
+    my $svflags = $sv->FLAGS;
+    if ($svflags & SVf_IOK) {
+	$obj->{flags} = VALID_INT|VALID_DOUBLE;
+	$obj->{type} = T_INT;
+	$obj->{nv} = $obj->{iv} = $sv->IV;
+    } elsif ($svflags & SVf_NOK) {
+	$obj->{flags} = VALID_INT|VALID_DOUBLE;
+	$obj->{type} = T_DOUBLE;
+	$obj->{iv} = $obj->{nv} = $sv->NV;
+    } else {
+	$obj->{type} = T_UNKNOWN;
+    }
+    return $obj;
+}
+
+sub B::Stackobj::Const::write_back {
+    my $obj = shift;
+    return if $obj->{flags} & VALID_SV;
+    # Save the SV object and replace $obj->{sv} by its C source code name
+    $obj->{sv} = $obj->{sv}->save;
+    $obj->{flags} |= VALID_SV|VALID_INT|VALID_DOUBLE;
+}
+
+sub B::Stackobj::Const::load_int {
+    my $obj = shift;
+    $obj->{iv} = int($obj->{sv}->PV);
+    $obj->{flags} |= VALID_INT;
+}
+
+sub B::Stackobj::Const::load_double {
+    my $obj = shift;
+    $obj->{nv} = $obj->{sv}->PV + 0.0;
+    $obj->{flags} |= VALID_DOUBLE;
+}
+
+sub B::Stackobj::Const::invalidate {}
+
+#
+# Stackobj::Bool
+#
+
+@B::Stackobj::Bool::ISA = 'B::Stackobj';
+sub B::Stackobj::Bool::new {
+    my ($class, $preg) = @_;
+    my $obj = bless {
+	type => T_INT,
+	flags => VALID_INT|VALID_DOUBLE,
+	iv => $$preg,
+	nv => $$preg,
+	preg => $preg		# this holds our ref to the pseudo-reg
+    }, $class;
+    return $obj;
+}
+
+sub B::Stackobj::Bool::write_back {
+    my $obj = shift;
+    return if $obj->{flags} & VALID_SV;
+    $obj->{sv} = "($obj->{iv} ? &sv_yes : &sv_no)";
+    $obj->{flags} |= VALID_SV;
+}
+
+# XXX Might want to handle as_double/set_double/load_double?
+
+sub B::Stackobj::Bool::invalidate {}
+
+1;
diff --git a/ext/B/B/Terse.pm b/ext/B/B/Terse.pm
new file mode 100644
index 0000000000..6489dc0afe
--- /dev/null
+++ b/ext/B/B/Terse.pm
@@ -0,0 +1,132 @@
+package B::Terse;
+use strict;
+use B qw(peekop class walkoptree_slow walkoptree_exec
+	 main_start main_root cstring svref_2object);
+use B::Asmdata qw(@specialsv_name);
+
+sub terse {
+    my ($order, $cvref) = @_;
+    my $cv = svref_2object($cvref);
+    if ($order eq "exec") {
+	walkoptree_exec($cv->START, "terse");
+    } else {
+	walkoptree_slow($cv->ROOT, "terse");
+    }
+}
+
+sub compile {
+    my $order = shift;
+    my @options = @_;
+    if (@options) {
+	return sub {
+	    my $objname;
+	    foreach $objname (@options) {
+		$objname = "main::$objname" unless $objname =~ /::/;
+		eval "terse(\$order, \\&$objname)";
+		die "terse($order, \\&$objname) failed: $@" if $@;
+	    }
+	}
+    } else {
+	if ($order eq "exec") {
+	    return sub { walkoptree_exec(main_start, "terse") }
+	} else {
+	    return sub { walkoptree_slow(main_root, "terse") }
+	}
+    }
+}
+
+sub indent {
+    my $level = shift;
+    return "    " x $level;
+}
+
+sub B::OP::terse {
+    my ($op, $level) = @_;
+    my $targ = $op->targ;
+    $targ = ($targ > 0) ? " [$targ]" : "";
+    print indent($level), peekop($op), $targ, "\n";
+}
+
+sub B::SVOP::terse {
+    my ($op, $level) = @_;
+    print indent($level), peekop($op), "  ";
+    $op->sv->terse(0);
+}
+
+sub B::GVOP::terse {
+    my ($op, $level) = @_;
+    print indent($level), peekop($op), "  ";
+    $op->gv->terse(0);
+}
+
+sub B::PMOP::terse {
+    my ($op, $level) = @_;
+    my $precomp = $op->precomp;
+    print indent($level), peekop($op),
+	defined($precomp) ? " /$precomp/\n" : " (regexp not compiled)\n";
+
+}
+
+sub B::PVOP::terse {
+    my ($op, $level) = @_;
+    print indent($level), peekop($op), " ", cstring($op->pv), "\n";
+}
+
+sub B::COP::terse {
+    my ($op, $level) = @_;
+    my $label = $op->label;
+    if ($label) {
+	$label = " label ".cstring($label);
+    }
+    print indent($level), peekop($op), $label, "\n";
+}
+
+sub B::PV::terse {
+    my ($sv, $level) = @_;
+    print indent($level);
+    printf "%s (0x%lx) %s\n", class($sv), $$sv, cstring($sv->PV);
+}
+
+sub B::AV::terse {
+    my ($sv, $level) = @_;
+    print indent($level);
+    printf "%s (0x%lx) FILL %d\n", class($sv), $$sv, $sv->FILL;
+}
+
+sub B::GV::terse {
+    my ($gv, $level) = @_;
+    my $stash = $gv->STASH->NAME;
+    if ($stash eq "main") {
+	$stash = "";
+    } else {
+	$stash = $stash . "::";
+    }
+    print indent($level);
+    printf "%s (0x%lx) *%s%s\n", class($gv), $$gv, $stash, $gv->NAME;
+}
+
+sub B::IV::terse {
+    my ($sv, $level) = @_;
+    print indent($level);
+    printf "%s (0x%lx) %d\n", class($sv), $$sv, $sv->IV;
+}
+
+sub B::NV::terse {
+    my ($sv, $level) = @_;
+    print indent($level);
+    printf "%s (0x%lx) %s\n", class($sv), $$sv, $sv->NV;
+}
+
+sub B::NULL::terse {
+    my ($sv, $level) = @_;
+    print indent($level);
+    printf "%s (0x%lx)\n", class($sv), $$sv;
+}
+    
+sub B::SPECIAL::terse {
+    my ($sv, $level) = @_;
+    print indent($level);
+    printf "%s #%d %s\n", class($sv), $$sv, $specialsv_name[$$sv];
+}
+
+1;
diff --git a/ext/B/B/Xref.pm b/ext/B/B/Xref.pm
new file mode 100644
index 0000000000..0102856919
--- /dev/null
+++ b/ext/B/B/Xref.pm
@@ -0,0 +1,392 @@
+package B::Xref;
+
+=head1 NAME
+
+B::Xref - Generates cross reference reports for Perl programs
+
+=head1 SYNOPSIS
+
+perl -MO=Xref[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+The B::Xref module is used to generate a cross reference listing of all
+definitions and uses of variables, subroutines and formats in a Perl program.
+It is implemented as a backend for the Perl compiler.
+
+The report generated is in the following format:
+
+    File filename1
+      Subroutine subname1
+	Package package1
+	  object1        C<line numbers>
+	  object2        C<line numbers>
+	  ...
+	Package package2
+	...
+
+Each B<File> section reports on a single file. Each B<Subroutine> section
+reports on a single subroutine apart from the special cases
+"(definitions)" and "(main)". These report, respectively, on subroutine
+definitions found by the initial symbol table walk and on the main part of
+the program or module external to all subroutines.
+
+The report is then grouped by the B<Package> of each variable,
+subroutine or format with the special case "(lexicals)" meaning
+lexical variables. Each B<object> name (implicitly qualified by its
+containing B<Package>) includes its type character(s) at the beginning
+where possible. Lexical variables are easier to track and even
+included dereferencing information where possible.
+
+The C<line numbers> are a comma separated list of line numbers (some
+preceded by code letters) where that object is used in some way.
+Simple uses aren't preceded by a code letter. Introductions (such as
+where a lexical is first defined with C<my>) are indicated with the
+letter "i". Subroutine and method calls are indicated by the character
+"&".  Subroutine definitions are indicated by "s" and format
+definitions by "f".
+
+=head1 OPTIONS
+
+Option words are separated by commas (not whitespace) and follow the
+usual conventions of compiler backend options.
+
+=over 8
+
+=item C<-oFILENAME>
+
+Directs output to C<FILENAME> instead of standard output.
+
+=item C<-r>
+
+Raw output. Instead of producing a human-readable report, outputs a line
+in machine-readable form for each definition/use of a variable/sub/format.
+
+=item C<-D[tO]>
+
+(Internal) debug options, probably only useful if C<-r> included.
+The C<t> option prints the object on the top of the stack as it's
+being tracked. The C<O> option prints each operator as it's being
+processed in the execution order of the program.
+
+=back
+
+=head1 BUGS
+
+Non-lexical variables are quite difficult to track through a program.
+Sometimes the type of a non-lexical variable's use is impossible to
+determine. Introductions of non-lexical non-scalars don't seem to be
+reported properly.
+
+=head1 AUTHOR
+
+Malcolm Beattie, mbeattie@sable.ox.ac.uk.
+
+=cut
+
+use strict;
+use B qw(peekop class comppadlist main_start svref_2object walksymtable);
+
+# Constants (should probably be elsewhere)
+sub OPpLVAL_INTRO () { 128 }
+sub SVf_POK () { 0x40000 }
+
+sub UNKNOWN { ["?", "?", "?"] }
+
+my @pad;			# lexicals in current pad
+				# as ["(lexical)", type, name]
+my %done;			# keyed by $$op: set when each $op is done
+my $top = UNKNOWN;		# shadows top element of stack as
+				# [pack, type, name] (pack can be "(lexical)")
+my $file;			# shadows current filename
+my $line;			# shadows current line number
+my $subname;			# shadows current sub name
+my %table;			# Multi-level hash to record all uses etc.
+my @todo = ();			# List of CVs that need processing
+
+my %code = (intro => "i", used => "",
+	    subdef => "s", subused => "&",
+	    formdef => "f", meth => "->");
+
+
+# Options
+my ($debug_op, $debug_top, $nodefs, $raw);
+
+sub process {
+    my ($var, $event) = @_;
+    my ($pack, $type, $name) = @$var;
+    if ($type eq "*") {
+	if ($event eq "used") {
+	    return;
+	} elsif ($event eq "subused") {
+	    $type = "&";
+	}
+    }
+    $type =~ s/(.)\*$/$1/g;
+    if ($raw) {
+	printf "%-16s %-12s %5d %-12s %4s %-16s %s\n",
+	    $file, $subname, $line, $pack, $type, $name, $event;
+    } else {
+	# Wheee
+	push(@{$table{$file}->{$subname}->{$pack}->{$type.$name}->{$event}},
+	    $line);
+    }
+}
+
+sub load_pad {
+    my $padlist = shift;
+    my ($namelistav, @namelist, $ix);
+    @pad = ();
+    return if class($padlist) eq "SPECIAL";
+    ($namelistav) = $padlist->ARRAY;
+    @namelist = $namelistav->ARRAY;
+    for ($ix = 1; $ix < @namelist; $ix++) {
+	my $namesv = $namelist[$ix];
+	next if class($namesv) eq "SPECIAL";
+	my ($type, $name) = $namesv->PV =~ /^(.)(.*)$/;
+	$pad[$ix] = ["(lexical)", $type, $name];
+    }
+}
+
+sub xref {
+    my $start = shift;
+    my $op;
+    for ($op = $start; $$op; $op = $op->next) {
+	last if $done{$$op}++;
+	warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top;
+	warn peekop($op), "\n" if $debug_op;
+	my $ppname = $op->ppaddr;
+	if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile)$/) {
+	    xref($op->other);
+	} elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") {
+	    xref($op->pmreplstart);
+	} elsif ($ppname eq "pp_substcont") {
+	    xref($op->other->pmreplstart);
+	    $op = $op->other;
+	    redo;
+	} elsif ($ppname eq "pp_cond_expr") {
+	    # pp_cond_expr never returns op_next
+	    xref($op->true);
+	    $op = $op->false;
+	    redo;
+	} elsif ($ppname eq "pp_enterloop") {
+	    xref($op->redoop);
+	    xref($op->nextop);
+	    xref($op->lastop);
+	} elsif ($ppname eq "pp_subst") {
+	    xref($op->pmreplstart);
+	} else {
+	    no strict 'refs';
+	    &$ppname($op) if defined(&$ppname);
+	}
+    }
+}
+
+sub xref_cv {
+    my $cv = shift;
+    my $pack = $cv->GV->STASH->NAME;
+    $subname = ($pack eq "main" ? "" : "$pack\::") . $cv->GV->NAME;
+    load_pad($cv->PADLIST);
+    xref($cv->START);
+    $subname = "(main)";
+}
+
+sub xref_object {
+    my $cvref = shift;
+    xref_cv(svref_2object($cvref));
+}
+
+sub xref_main {
+    $subname = "(main)";
+    load_pad(comppadlist);
+    xref(main_start);
+    while (@todo) {
+	xref_cv(shift @todo);
+    }
+}
+
+sub pp_nextstate {
+    my $op = shift;
+    $file = $op->filegv->SV->PV;
+    $line = $op->line;
+    $top = UNKNOWN;
+}
+
+sub pp_padsv {
+    my $op = shift;
+    $top = $pad[$op->targ];
+    process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
+}
+
+sub pp_padav { pp_padsv(@_) }
+sub pp_padhv { pp_padsv(@_) }
+
+sub deref {
+    my ($var, $as) = @_;
+    $var->[1] = $as . $var->[1];
+    process($var, "used");
+}
+
+sub pp_rv2cv { deref($top, "&"); }
+sub pp_rv2hv { deref($top, "%"); }
+sub pp_rv2sv { deref($top, "\$"); }
+sub pp_rv2av { deref($top, "\@"); }
+sub pp_rv2gv { deref($top, "*"); }
+
+sub pp_gvsv {
+    my $op = shift;
+    my $gv = $op->gv;
+    $top = [$gv->STASH->NAME, '$', $gv->NAME];
+    process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
+}
+
+sub pp_gv {
+    my $op = shift;
+    my $gv = $op->gv;
+    $top = [$gv->STASH->NAME, "*", $gv->NAME];
+    process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
+}
+
+sub pp_const {
+    my $op = shift;
+    my $sv = $op->sv;
+    $top = ["?", "",
+	    (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"];
+}
+
+sub pp_method {
+    my $op = shift;
+    $top = ["(method)", "->".$top->[1], $top->[2]];
+}
+
+sub pp_entersub {
+    my $op = shift;
+    if ($top->[1] eq "m") {
+	process($top, "meth");
+    } else {
+	process($top, "subused");
+    }
+    $top = UNKNOWN;
+}
+
+#
+# Stuff for cross referencing definitions of variables and subs
+#
+
+sub B::GV::xref {
+    my $gv = shift;
+    my $cv = $gv->CV;
+    if ($$cv) {
+	#return if $done{$$cv}++;
+	$file = $gv->FILEGV->SV->PV;
+	$line = $gv->LINE;
+	process([$gv->STASH->NAME, "&", $gv->NAME], "subdef");
+	push(@todo, $cv);
+    }
+    my $form = $gv->FORM;
+    if ($$form) {
+	return if $done{$$form}++;
+	$file = $gv->FILEGV->SV->PV;
+	$line = $gv->LINE;
+	process([$gv->STASH->NAME, "", $gv->NAME], "formdef");
+    }
+}
+
+sub xref_definitions {
+    my ($pack, %exclude);
+    return if $nodefs;
+    $subname = "(definitions)";
+    foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS
+		      strict vars FileHandle Exporter Carp)) {
+        $exclude{$pack."::"} = 1;
+    }
+    no strict qw(vars refs);
+    walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) });
+}
+
+sub output {
+    return if $raw;
+    my ($file, $subname, $pack, $name, $ev, $perfile, $persubname,
+	$perpack, $pername, $perev);
+    foreach $file (sort(keys(%table))) {
+	$perfile = $table{$file};
+	print "File $file\n";
+	foreach $subname (sort(keys(%$perfile))) {
+	    $persubname = $perfile->{$subname};
+	    print "  Subroutine $subname\n";
+	    foreach $pack (sort(keys(%$persubname))) {
+		$perpack = $persubname->{$pack};
+		print "    Package $pack\n";
+		foreach $name (sort(keys(%$perpack))) {
+		    $pername = $perpack->{$name};
+		    my @lines;
+		    foreach $ev (qw(intro formdef subdef meth subused used)) {
+			$perev = $pername->{$ev};
+			if (defined($perev) && @$perev) {
+			    my $code = $code{$ev};
+			    push(@lines, map("$code$_", @$perev));
+			}
+		    }
+		    printf "      %-16s  %s\n", $name, join(", ", @lines);
+		}
+	    }
+	}
+    }
+}
+
+sub compile {
+    my @options = @_;
+    my ($option, $opt, $arg);
+  OPTION:
+    while ($option = shift @options) {
+	if ($option =~ /^-(.)(.*)/) {
+	    $opt = $1;
+	    $arg = $2;
+	} else {
+	    unshift @options, $option;
+	    last OPTION;
+	}
+	if ($opt eq "-" && $arg eq "-") {
+	    shift @options;
+	    last OPTION;
+	} elsif ($opt eq "o") {
+	    $arg ||= shift @options;
+	    open(STDOUT, ">$arg") or return "$arg: $!\n";
+	} elsif ($opt eq "d") {
+	    $nodefs = 1;
+	} elsif ($opt eq "r") {
+	    $raw = 1;
+	} elsif ($opt eq "D") {
+            $arg ||= shift @options;
+	    foreach $arg (split(//, $arg)) {
+		if ($arg eq "o") {
+		    B->debug(1);
+		} elsif ($arg eq "O") {
+		    $debug_op = 1;
+		} elsif ($arg eq "t") {
+		    $debug_top = 1;
+		}
+	    }
+	}
+    }
+    if (@options) {
+	return sub {
+	    my $objname;
+	    xref_definitions();
+	    foreach $objname (@options) {
+		$objname = "main::$objname" unless $objname =~ /::/;
+		eval "xref_object(\\&$objname)";
+		die "xref_object(\\&$objname) failed: $@" if $@;
+	    }
+	    output();
+	}
+    } else {
+	return sub {
+	    xref_definitions();
+	    xref_main();
+	    output();
+	}
+    }
+}
+
+1;
diff --git a/ext/B/B/assemble b/ext/B/B/assemble
new file mode 100755
index 0000000000..43cc5bc4b3
--- /dev/null
+++ b/ext/B/B/assemble
@@ -0,0 +1,30 @@
+use B::Assembler qw(assemble_fh);
+use FileHandle;
+
+my ($filename, $fh, $out);
+
+if ($ARGV[0] eq "-d") {
+    B::Assembler::debug(1);
+    shift;
+}
+
+$out = \*STDOUT;
+
+if (@ARGV == 0) {
+    $fh = \*STDIN;
+    $filename = "-";
+} elsif (@ARGV == 1) {
+    $filename = $ARGV[0];
+    $fh = new FileHandle "<$filename";
+} elsif (@ARGV == 2) {
+    $filename = $ARGV[0];
+    $fh = new FileHandle "<$filename";
+    $out = new FileHandle ">$ARGV[1]";
+} else {
+    die "Usage: assemble [filename] [outfilename]\n";
+}
+
+binmode $out;
+$SIG{__WARN__} = sub { warn "$filename:@_" };
+$SIG{__DIE__} = sub { die "$filename: @_" };
+assemble_fh($fh, sub { print $out @_ });
diff --git a/ext/B/B/cc_harness b/ext/B/B/cc_harness
new file mode 100644
index 0000000000..79f8727a8f
--- /dev/null
+++ b/ext/B/B/cc_harness
@@ -0,0 +1,12 @@
+use Config;
+
+$libdir = $ENV{PERL_SRC} || "$Config{installarchlib}/CORE";
+
+if (!grep(/^-[cS]$/, @ARGV)) {
+    $linkargs = sprintf("%s $libdir/$Config{libperl} %s",
+			@Config{qw(ldflags libs)});
+}
+
+$cccmd = "$Config{cc} $Config{ccflags} -I$libdir @ARGV $linkargs";
+print "$cccmd\n";
+exec $cccmd;
diff --git a/ext/B/B/disassemble b/ext/B/B/disassemble
new file mode 100755
index 0000000000..6530b80950
--- /dev/null
+++ b/ext/B/B/disassemble
@@ -0,0 +1,22 @@
+use B::Disassembler qw(disassemble_fh);
+use FileHandle;
+
+my $fh;
+if (@ARGV == 0) {
+    $fh = \*STDIN;
+} elsif (@ARGV == 1) {
+    $fh = new FileHandle "<$ARGV[0]";
+} else {
+    die "Usage: disassemble [filename]\n";
+}
+
+sub print_insn {
+    my ($insn, $arg) = @_;
+    if (defined($arg)) {
+	printf "%s %s\n", $insn, $arg;
+    } else {
+	print $insn, "\n";
+    }
+}
+
+disassemble_fh($fh, \&print_insn);
diff --git a/ext/B/B/makeliblinks b/ext/B/B/makeliblinks
new file mode 100644
index 0000000000..82560783c0
--- /dev/null
+++ b/ext/B/B/makeliblinks
@@ -0,0 +1,54 @@
+use File::Find;
+use Config;
+
+if (@ARGV != 2) {
+    warn <<"EOT";
+Usage: makeliblinks libautodir targetdir
+where libautodir is the architecture-dependent auto directory
+(e.g. $Config::Config{archlib}/auto).
+EOT
+    exit 2;
+}
+
+my ($libautodir, $targetdir) = @ARGV;
+
+# Calculate relative path prefix from $targetdir to $libautodir
+sub relprefix {
+    my ($to, $from) = @_;
+    my $up;
+    for ($up = 0; substr($to, 0, length($from)) ne $from; $up++) {
+	$from =~ s(
+		   [^/]+	(?# a group of non-slashes) 
+		   /*		(?# maybe with some trailing slashes)
+		   $		(?# at the end of the path)
+                  )()x;
+    }
+    return (("../" x $up) . substr($to, length($from)));
+}
+
+my $relprefix = relprefix($libautodir, $targetdir);
+
+my ($dlext, $lib_ext) = @Config::Config{qw(dlext lib_ext)};
+
+sub link_if_library {
+    if (/\.($dlext|$lib_ext)$/o) {
+	my $ext = $1;
+	my $name = $File::Find::name;
+	if (substr($name, 0, length($libautodir) + 1) ne "$libautodir/") {
+	    die "directory of $name doesn't match $libautodir\n";
+	}
+	substr($name, 0, length($libautodir) + 1) = '';
+	my @parts = split(m(/), $name);
+	if ($parts[-1] ne "$parts[-2].$ext") {
+	    die "module name $_ doesn't match its directory $libautodir\n";
+	}
+	pop @parts;
+	my $libpath = "$targetdir/lib" . join("__", @parts) . ".$ext";
+	print "$libpath -> $relprefix/$name\n";
+	symlink("$relprefix/$name", $libpath)
+	    or warn "above link failed with error: $!\n";
+    }
+}
+
+find(\&link_if_library, $libautodir);
+exit 0;
diff --git a/ext/B/Makefile.PL b/ext/B/Makefile.PL
new file mode 100644
index 0000000000..bc42a34d33
--- /dev/null
+++ b/ext/B/Makefile.PL
@@ -0,0 +1,54 @@
+use ExtUtils::MakeMaker;
+use Config;
+
+my $e = $Config{'exe_ext'};
+my $o = $Config{'obj_ext'};
+my $exeout_flag = '-o ';
+my @extras = ();
+if ($^O eq 'MSWin32') {
+    if ($Config{'cc'} =~ /^cl/i) {
+	$exeout_flag = '-Fe';
+    }
+    elsif ($Config{'cc'} =~ /^bcc/i) {
+	$exeout_flag = '-e';
+    }
+    # XXX this probably applies to everyone else
+    @extras = (
+    OBJECT	=> "B$o byterun$o",
+    depend	=> {
+	"B$o"		=> "B.c ../../bytecode.h ../../byterun.h",
+	"byterun$o"	=> "../../byterun.c ../../bytecode.h ../../byterun.h",
+    });
+}
+
+WriteMakefile(
+    NAME	=> "B",
+    VERSION	=> "a5",
+    @extras,
+    clean	=> {
+	FILES		=> "perl byteperl$e *$o B.c *~"
+    }
+);
+
+sub MY::post_constants {
+    "\nLIBS = $Config{libs}\n"
+}
+
+# Leave out doing byteperl for now. Probably should be built in the
+# core directory or somewhere else rather than here
+#sub MY::top_targets {
+#    my $self = shift;
+#    my $targets = $self->MM::top_targets();
+#    $targets =~ s/^(all ::.*)$/$1 byteperl$e/m;
+#    return <<"EOT" . $targets;
+
+#
+# byteperl is *not* a standard perl+XSUB executable. It's a special
+# program for running standalone bytecode executables. It isn't an XSUB
+# at the moment because a standlone Perl program needs to set up curpad
+# which is overwritten on exit from an XSUB.
+#
+#byteperl$e : byteperl$o B$o \$(PERL_SRC)/byterun$o
+#	\$(CC) ${exeout_flag}byteperl$e byteperl$o B$o byterun$o \$(LDFLAGS) \$(PERL_ARCHLIB)/CORE/$Config{libperl} \$(LIBS)
+#EOT
+#}
diff --git a/ext/B/NOTES b/ext/B/NOTES
new file mode 100644
index 0000000000..ee10ba03e9
--- /dev/null
+++ b/ext/B/NOTES
@@ -0,0 +1,168 @@
+C backend invocation
+	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.
+	-ofilename	Output to filename instead of STDOUT
+	-v		Verbose (currently gives a few compilation statistics)
+	--		Force end of options
+	-uPackname	Force apparently unused subs from package Packname to
+			be compiled. This allows programs to use eval "foo()"
+			even when sub foo is never seen to be used at compile
+			time. The down side is that any subs which really are
+			never used also have code generated. This option is
+			necessary, for example, if you have a signal handler
+			foo which you initialise with $SIG{BAR} = "foo".
+			A better fix, though, is just to change it to
+			$SIG{BAR} = \&foo. You can have multiple -u options.
+	-D		Debug options (concat or separate flags like perl -D)
+		o	OPs, prints each OP as it's processed
+		c	COPs, prints COPs as processed (incl. file & line num)
+		A	prints AV information on saving
+		C	prints CV information on saving
+		M	prints MAGIC information on saving
+	-f		Force optimisations on or off one at a time.
+		cog	Copy-on-grow: PVs declared and initialised statically
+		no-cog	No copy-on-grow
+	-On		Optimisation level (n = 0, 1, 2, ...). -O means -O1.
+			Currently, -O1 and higher set -fcog.
+
+Examples
+	perl -MO=C foo.pl > foo.c
+	perl cc_harness -o foo foo.c
+
+	perl -MO=C,-v,-DcA bar.pl > /dev/null
+
+CC backend invocation
+	If there are any non-option arguments, they are taken to be names of
+	subs to be saved. Without extra arguments, it saves the main program.
+	-ofilename	Output to filename instead of STDOUT
+	--		Force end of options
+	-uPackname	Force apparently unused subs from package Packname to
+			be compiled. This allows programs to use eval "foo()"
+			even when sub foo is never seen to be used at compile
+			time. The down side is that any subs which really are
+			never used also have code generated. This option is
+			necessary, for example, if you have a signal handler
+			foo which you initialise with $SIG{BAR} = "foo".
+			A better fix, though, is just to change it to
+			$SIG{BAR} = \&foo. You can have multiple -u options.
+	-mModulename	Instead of generating source for a runnable executable,
+			generate source for an XSUB module. The
+			boot_Modulename function (which DynaLoader can look
+			for) does the appropriate initialisation and runs the
+			main part of the Perl source that is being compiled.
+	-pn		Generate code for perl patchlevel n (e.g. 3 or 4).
+			The default is to generate C code which will link
+			with the currently executing version of perl.
+			running the perl compiler.
+	-D		Debug options (concat or separate flags like perl -D)
+		r	Writes debugging output to STDERR just as it's about
+			to write to the program's runtime (otherwise writes
+			debugging info as comments in its C output).
+		O	Outputs each OP as it's compiled
+		s	Outputs the contents of the shadow stack at each OP
+		p	Outputs the contents of the shadow pad of lexicals as
+			it's loaded for each sub or the main program.
+		q	Outputs the name of each fake PP function in the queue
+			as it's about to processes.
+		l	Output the filename and line number of each original
+			line of Perl code as it's processed (pp_nextstate).
+		t	Outputs timing information of compilation stages
+	-f		Force optimisations on or off one at a time.
+		[
+		cog	Copy-on-grow: PVs declared and initialised statically
+		no-cog	No copy-on-grow
+		These two not in CC yet.
+		]
+		freetmps-each-bblock	Delays FREETMPS from the end of each
+					statement to the end of the each basic
+					block.
+		freetmps-each-loop	Delays FREETMPS from the end of each
+					statement to the end of the group of
+					basic blocks forming a loop. At most
+					one of the freetmps-each-* options can
+					be used.
+		omit-taint		Omits generating code for handling
+					perl's tainting mechanism.
+	-On		Optimisation level (n = 0, 1, 2, ...). -O means -O1.
+			Currently, -O1 sets -ffreetmps-each-bblock and -O2
+			sets -ffreetmps-each-loop.
+
+Example
+	perl -MO=CC,-O2,-ofoo.c foo.pl
+	perl cc_harness -o foo foo.c
+
+	perl -MO=CC,-mFoo,-oFoo.c Foo.pm
+	perl cc_harness -shared -c -o Foo.so Foo.c
+
+
+Bytecode backend invocation
+
+	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.
+	-ofilename	Output to filename instead of STDOUT.
+	--		Force end of options.
+	-f		Force optimisations on or off one at a time.
+			Each can be preceded by no- to turn the option off.
+		compress-nullops
+			Only fills in the necessary fields of ops which have
+			been optimised away by perl's internal compiler.
+		omit-sequence-numbers
+			Leaves out code to fill in the op_seq field of all ops
+			which is only used by perl's internal compiler.
+		bypass-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.
+		strip-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 "goto label" statements from working.
+	-On		Optimisation level (n = 0, 1, 2, ...). -O means -O1.
+			-O1 sets -fcompress-nullops -fomit-sequence numbers.
+			-O6 adds -fstrip-syntax-tree.
+	-D		Debug options (concat or separate flags like perl -D)
+		o	OPs, prints each OP as it's processed.
+		b	print debugging information about bytecompiler progress
+		a	tells the assembler to include source assembler lines
+			in its output as bytecode comments.
+		C	prints each CV taken from the final symbol tree walk.
+	-S		Output assembler source rather than piping it
+			through the assembler and outputting bytecode.
+	-m		Compile as a module rather than a standalone program.
+			Currently this just means that the bytecodes for
+			initialising main_start, main_root and curpad are
+			omitted.
+
+Example
+	perl -MO=Bytecode,-O6,-o,foo.plc foo.pl
+
+	perl -MO=Bytecode,-S foo.pl > foo.S
+	assemble foo.S > foo.plc
+	byteperl foo.plc
+
+	perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm
+
+Backends for debugging
+	perl -MO=Terse,exec foo.pl
+	perl -MO=Debug bar.pl
+
+O module
+	Used with "perl -MO=Backend,foo,bar prog.pl" to invoke the backend
+	B::Backend with options foo and bar. O invokes the sub
+	B::Backend::compile() with arguments foo and bar at BEGIN time.
+	That compile() sub must do any inital argument processing replied.
+	If unsuccessful, it should return a string which O arranges to be
+	printed as an error message followed by a clean error exit. In the
+	normal case where any option processing in compile() is successful,
+	it should return a sub ref (usually a closure) to perform the
+	actual compilation. When O regains control, it ensures that the
+	"-c" option is forced (so that the program being compiled doesn't
+	end up running) and registers an END block to call back the sub ref
+	returned from the backend's compile(). Perl then continues by
+	parsing prog.pl (just as it would with "perl -c prog.pl") and after
+	doing so, assuming there are no parse-time errors, the END block
+	of O gets called and the actual backend compilation happens. Phew.
diff --git a/ext/B/O.pm b/ext/B/O.pm
new file mode 100644
index 0000000000..40d336e122
--- /dev/null
+++ b/ext/B/O.pm
@@ -0,0 +1,21 @@
+package O;
+use B qw(minus_c);
+use Carp;    
+
+sub import {
+    my ($class, $backend, @options) = @_;
+    eval "use B::$backend ()";
+    if ($@) {
+	croak "use of backend $backend failed: $@";
+    }
+    my $compilesub = &{"B::${backend}::compile"}(@options);
+    if (ref($compilesub) eq "CODE") {
+	minus_c;
+	eval 'END { &$compilesub() }';
+    } else {
+	die $compilesub;
+    }
+}
+
+1;
+
diff --git a/ext/B/README b/ext/B/README
new file mode 100644
index 0000000000..4e4ed25fdc
--- /dev/null
+++ b/ext/B/README
@@ -0,0 +1,325 @@
+		  Perl Compiler Kit, Version alpha4
+
+		 Copyright (c) 1996, 1997, Malcolm Beattie
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of either:
+
+	a) the GNU General Public License as published by the Free
+	Software Foundation; either version 1, or (at your option) any
+	later version, or
+
+	b) the "Artistic License" which comes with this kit.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See either
+    the GNU General Public License or the Artistic License for more details.
+
+    You should have received a copy of the Artistic License with this kit,
+    in the file named "Artistic".  If not, you can get one from the Perl
+    distribution. You should also have received a copy of the GNU General
+    Public License, in the file named "Copying". If not, you can get one
+    from the Perl distribution or else write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+CHANGES
+
+New since alpha3
+    Anonymous subs work properly with C and CC.
+    Heuristics for forcing compilation of apparently unused subs/methods.
+    Subs which use the AutoLoader module are forcibly loaded at compile-time.
+    Slightly faster compilation.
+    Handles slightly more complex code within a BEGIN { }.
+    Minor bug fixes.
+
+New since alpha2
+    CC backend now supports ".." and s//e.
+    Xref backend generates cross-reference reports
+    Cleanups to fix benign but irritating "-w" warnings
+    Minor cxstack fix
+New since alpha1
+    Working CC backend
+    Shared globs and pre-initialised hash support
+    Some XSUB support
+    Assorted bug fixes
+
+INSTALLATION
+
+(1) You need perl5.002 or later.
+
+(2) If you want to compile and run programs with the C or CC backends
+which undefine (or redefine) subroutines, then you need to apply a
+one-line patch to perl itself. One or two of the programs in perl's
+own test suite do this. The patch is in file op.patch. It prevents
+perl from calling free() on OPs with the magic sequence number (U16)-1.
+The compiler declares all OPs as static structures and uses that magic
+sequence number.
+
+(3) Type
+    perl Makefile.PL
+to write a personalised Makefile for your system. If you want the
+bytecode modules to support reading bytecode from strings (instead of
+just from files) then add the option
+    -DINDIRECT_BGET_MACROS
+into the middle of the definition of the CCCMD macro in the Makefile.
+Your C compiler may need to be able to cope with Standard C for this.
+I haven't tested this option yet with an old pre-Standard compiler.
+
+(4) If your platform supports dynamic loading then just type
+    make
+and you can then use
+    perl -Iblib/arch -MO=foo bar
+to use the compiler modules (see later for details).
+If you need/want instead to make a statically linked perl which
+contains the appropriate modules, then type
+    make perl
+    make byteperl
+and you can then use
+    ./perl -MO=foo bar
+to use the compiler modules.    
+In both cases, the byteperl executable is required for running standalone
+bytecode programs. It is *not* a standard perl+XSUB perl executable.
+
+USAGE
+
+As of the alpha3 release, the Bytecode, C and CC backends are now all
+functional enough to compile almost the whole of the main perl test
+suite. In the case of the CC backend, any failures are all due to
+differences and/or known bugs documented below. See the file TESTS.
+In the following examples, you'll need to replace "perl" by
+    perl -Iblib/arch
+if you have built the extensions for a dynamic loading platform but
+haven't installed the extensions completely. You'll need to replace
+"perl" by
+    ./perl
+if you have built the extensions into a statically linked perl binary.
+
+(1) To compile perl program foo.pl with the C backend, do
+    perl -MO=C,-ofoo.c foo.pl
+Then use the cc_harness perl program to compile the resulting C source:
+    perl cc_harness -O2 -o foo foo.c
+
+If you are using a non-ANSI pre-Standard C compiler that can't handle
+pre-declaring static arrays, then add -DBROKEN_STATIC_REDECL to the
+options you use:
+    perl cc_harness -O2 -o foo -DBROKEN_STATIC_REDECL foo.c
+If you are using a non-ANSI pre-Standard C compiler that can't handle
+static initialisation of structures with union members then add
+-DBROKEN_UNION_INIT to the options you use. If you want command line
+arguments passed to your executable to be interpreted by perl (e.g. -Dx)
+then compile foo.c with -DALLOW_PERL_OPTIONS. Otherwise, all command line
+arguments passed to foo will appear directly in @ARGV.  The resulting
+executable foo is the compiled version of foo.pl. See the file NOTES for
+extra options you can pass to -MO=C.
+
+There are some constraints on the contents on foo.pl if you want to be
+able to compile it successfully. Some problems can be fixed fairly easily
+by altering foo.pl; some problems with the compiler are known to be
+straightforward to solve and I'll do so soon. The file Todo lists a
+number of known problems. See the XSUB section lower down for information
+about compiling programs which use XSUBs.
+
+(2) To compile foo.pl with the CC backend (which generates actual
+optimised C code for the execution path of your perl program), use
+    perl -MO=CC,-ofoo.c foo.pl
+
+and proceed just as with the C backend. You should almost certainly
+use an option such as -O2 with the subsequent cc_harness invocation
+so that your C compiler uses optimisation. The C code generated by
+the Perl compiler's CC backend looks ugly to humans but is easily
+optimised by C compilers.
+
+To make the most of this compiler backend, you need to tell the
+compiler when you're using int or double variables so that it can
+optimise appropriately (although this part of the compiler is the most
+buggy). You currently do that by naming lexical variables ending in
+"_i" for ints, "_d" for doubles, "_ir" for int "register" variables or
+"_dr" for double "register" variables. Here "register" is a promise
+that you won't pass a reference to the variable into a sub which then
+modifies the variable. The compiler ought to catch attempts to use
+"\$i" just as C compilers catch attempts to do "&i" for a register int
+i but it doesn't at the moment. Bugs in the CC backend may make your
+program fail in mysterious ways and give wrong answers rather than just
+crash in boring ways. But, hey, this is an alpha release so you knew
+that anyway. See the XSUB section lower down for information about
+compiling programs which use XSUBs.
+
+If your program uses classes which define methods (or other subs which
+are not exported and not apparently used until runtime) then you'll
+need to use -u compile-time options (see the NOTES file) to force the
+subs to be compiled. Future releases will probably default the other
+way, do more auto-detection and provide more fine-grained control.
+
+Since compiled executables need linking with libperl, you may want
+to turn libperl.a into a shared library if your platform supports
+it. For example, with Digital UNIX, do something like
+    ld -shared -o libperl.so -all libperl.a -none -lc
+and with Linux/ELF, rebuild the perl .c files with -fPIC (and I
+also suggest -fomit-frame-pointer for Linux on Intel architetcures),
+do "make libperl.a" and then do
+    gcc -shared -Wl,-soname,libperl.so.5 -o libperl.so.5.3 `ar t libperl.a`
+and then
+    # cp libperl.so.5.3 /usr/lib
+    # cd /usr/lib
+    # ln -s libperl.so.5.3 libperl.so.5
+    # ln -s libperl.so.5 libperl.so
+    # ldconfig
+When you compile perl executables with cc_harness, append -L/usr/lib
+otherwise the -L for the perl source directory will override it. For
+example,
+    perl -Iblib/arch -MO=CC,-O2,-ofoo3.c foo3.bench
+    perl cc_harness -o foo3 -O2 foo3.c -L/usr/lib
+    ls -l foo3
+    -rwxr-xr-x   1 mbeattie xzdg        11218 Jul  1 15:28 foo3
+You'll probably also want to link your main perl executable against
+libperl.so; it's nice having an 11K perl executable.
+
+(3) To compile foo.pl into bytecode do
+    perl -MO=Bytecode,-ofoo foo.pl
+To run the resulting bytecode file foo as a standalone program, you
+use the program byteperl which should have been built along with the
+extensions.
+    ./byteperl foo
+Any extra arguments are passed in as @ARGV; they are not interpreted
+as perl options. If you want to load chunks of bytecode into an already
+running perl program then use the -m option and investigate the
+byteload_fh and byteload_string functions exported by the B module.
+See the NOTES file for details of these and other options (including
+optimisation options and ways of getting at the intermediate "assembler"
+code that the Bytecode backend uses).
+
+(3) There are little Bourne shell scripts and perl programs to aid with
+some common operations: assemble, disassemble, run_bytecode_test,
+run_test, cc_harness, test_harness, test_harness_bytecode.
+
+(4) Walk the op tree in execution order printing terse info about each op
+    perl -MO=Terse,exec foo.pl
+
+(5) Walk the op tree in syntax order printing lengthier debug info about
+each op. You can also append ",exec" to walk in execution order, but the
+formatting is designed to look nice with Terse rather than Debug.
+    perl -MO=Debug foo.pl
+
+(6) Produce a cross-reference report of the line numbers at which all
+variables, subs and formats are defined and used.
+    perl -MO=Xref foo.pl
+
+XSUBS
+
+The C and CC backends can successfully compile some perl programs which
+make use of XSUB extensions. [I'll add more detail to this section in a
+later release.] As a prerequisite, such extensions must not need to do
+anything in their BOOT: section which needs to be done at runtime rather
+than compile time. Normally, the only code in the boot_Foo() function is
+a list of newXS() calls which xsubpp puts there and the compiler handles
+saving those XS subs itself. For each XSUB used, the C and CC compiler
+will generate an initialiser in their C output which refers to the name
+of the relevant C function (XS_Foo_somesub). What is not yet automated
+is the necessary commands and cc command-line options (e.g. via
+"perl cc_harness") which link against the extension libraries. For now,
+you need the XSUB extension to have installed files in the right format
+for using as C libraries (e.g. Foo.a or Foo.so). As the Foo.so files (or
+your platform's version) aren't suitable for linking against, you will
+have to reget the extension source and rebuild it as a static extension
+to force the generation of a suitable Foo.a file. Then you need to make
+a symlink (or copy or rename) of that file into a libFoo.a suitable for
+cc linking. Then add the appropriate -L and -l options to your
+"perl cc_harness" command line to find and link against those libraries.
+You may also need to fix up some platform-dependent environment variable
+to ensure that linked-against .so files are found at runtime too.
+
+DIFFERENCES
+
+The result of running a compiled Perl program can sometimes be different
+from running the same program with standard perl. Think of the compiler
+as having a slightly different implementation of the language Perl.
+Unfortunately, since Perl has had a single implementation until now,
+there are no formal standards or documents defining what behaviour is
+guaranteed of Perl the language and what just "happens to work".
+Some of the differences below are almost impossible to change because of
+the way the compiler works. Others can be changed to produce "standard"
+perl behaviour if it's deemed proper and the resulting performance hit
+is accepted. I'll use "standard perl" to mean the result of running a
+Perl program using the perl executable from the perl distribution.
+I'll use "compiled Perl program" to mean running an executable produced
+by this compiler kit ("the compiler") with the CC backend.
+
+Loops
+    Standard perl calculates the target of "next", "last", and "redo"
+    at run-time. The compiler calculates the targets at compile-time.
+    For example, the program
+
+        sub skip_on_odd { next NUMBER if $_[0] % 2 }
+        NUMBER: for ($i = 0; $i < 5; $i++) {
+            skip_on_odd($i);
+            print $i;
+        }
+
+    produces the output
+        024
+    with standard perl but gives a compile-time error with the compiler.
+
+Context of ".."
+    The context (scalar or array) of the ".." operator determines whether
+    it behaves as a range or a flip/flop. Standard perl delays until
+    runtime the decision of which context it is in but the compiler needs
+    to know the context at compile-time. For example,
+	@a = (4,6,1,0,0,1);
+	sub range { (shift @a)..(shift @a) }
+	print range();
+	while (@a) { print scalar(range()) }
+    generates the output
+        456123E0
+    with standard Perl but gives a compile-time error with compiled Perl.
+
+Arithmetic
+    Compiled Perl programs use native C arithemtic much more frequently
+    than standard perl. Operations on large numbers or on boundary
+    cases may produce different behaviour.
+
+Deprecated features
+    Features of standard perl such as $[ which have been deprecated
+    in standard perl since version 5 was released have not been
+    implemented in the compiler.
+
+Others
+    I'll add to this list as I remember what they are.
+
+BUGS
+
+Here are some things which may cause the compiler problems.
+
+The following render the compiler useless (without serious hacking):
+* Use of the DATA filehandle (via __END__ or __DATA__ tokens)
+* Operator overloading with %OVERLOAD
+* The (deprecated) magic array-offset variable $[ does not work
+* The following operators are not yet implemented for CC
+    goto
+    sort with a non-default comparison (i.e. a named sub or inline block)
+* You can't use "last" to exit from a non-loop block.
+
+The following may give significant problems:
+* BEGIN blocks containing complex initialisation code
+* Code which is only ever referred to at runtime (e.g. via eval "..." or
+  via method calls): see the -u option for the C and CC backends.
+* Run-time lookups of lexical variables in "outside" closures
+
+The following may cause problems (not thoroughly tested):
+* Dependencies on whether values of some "magic" Perl variables are
+  determined at compile-time or runtime.
+* For the C and CC backends: compile-time strings which are longer than
+  your C compiler can cope with in a single line or definition.
+* Reliance on intimate details of global destruction
+* For the Bytecode backend: high -On optimisation numbers with code
+  that has complex flow of control.
+* Any "-w" option in the first line of your perl program is seen and
+  acted on by perl itself before the compiler starts. The compiler
+  itself then runs with warnings turned on. This may cause perl to
+  print out warnings about the compiler itself since I haven't tested
+  it thoroughly with warnings turned on.
+
+There is a terser but more complete list in the Todo file.
+
+Malcolm Beattie
+2 September 1996
diff --git a/ext/B/TESTS b/ext/B/TESTS
new file mode 100644
index 0000000000..e050f6cfdd
--- /dev/null
+++ b/ext/B/TESTS
@@ -0,0 +1,78 @@
+Test results from compiling t/*/*.t
+		C		Bytecode	CC
+
+base/cond.t	OK		ok		OK
+base/if.t	OK		ok		OK
+base/lex.t	OK		ok		OK
+base/pat.t	OK		ok		OK
+base/term.t	OK		ok		OK
+cmd/elsif.t	OK		ok		OK
+cmd/for.t	OK		ok		ok 1, 2, 3, panic: pp_iter
+cmd/mod.t	OK		ok		ok
+cmd/subval.t	OK		ok		1..34, not ok 27,28 (simply
+						because filename changes).
+cmd/switch.t	OK		ok		ok
+cmd/while.t	OK		ok		ok
+io/argv.t	OK		ok		ok
+io/dup.t	OK		ok		ok
+io/fs.t		OK		ok		ok
+io/inplace.t	OK		ok		ok
+io/pipe.t	OK		ok		ok with -umain
+io/print.t	OK		ok		ok
+io/tell.t	OK		ok		ok
+op/append.t	OK		ok		OK
+op/array.t	OK		ok		1..36, not ok 7,10 (no $[)
+op/auto.t	OK		ok		OK
+op/chop.t	OK		ok		OK
+op/cond.t	OK		ok		OK
+op/delete.t	OK		ok		OK
+op/do.t		OK		ok		OK
+op/each.t	OK		ok		OK
+op/eval.t	OK		ok		ok 1-6 of 16 then exits
+op/exec.t	OK		ok		OK
+op/exp.t	OK		ok		OK
+op/flip.t	OK		ok		OK
+op/fork.t	OK		ok		OK
+op/glob.t	OK		ok		OK
+op/goto.t	OK		ok		1..9, Can't find label label1.
+op/groups.t	OK (s/ucb/bin/ under Linux)	OK 1..0 for now.
+op/index.t	OK		ok		OK
+op/int.t	OK		ok		OK
+op/join.t	OK		ok		OK
+op/list.t	OK		ok		OK
+op/local.t	OK		ok		OK
+op/magic.t	OK		ok		OK
+op/misc.t	no DATA filehandle so succeeds trivially with 1..0
+op/mkdir.t	OK		ok		OK
+op/my.t		OK		ok		OK
+op/oct.t	OK		ok		OK (C large const warnings)
+op/ord.t	OK		ok		OK
+op/overload.t	Mostly not ok	Mostly not ok	C errors.
+op/pack.t	OK		ok		OK
+op/pat.t	omit 26 (reset)	ok		[lots of memory for compile]
+op/push.t	OK		ok		OK
+op/quotemeta.t	OK		ok		OK
+op/rand.t	OK		ok		
+op/range.t	OK		ok		OK
+op/read.t	OK		ok		OK
+op/readdir.t	OK		ok		OK (substcont works too)
+op/ref.t	omits "ok 40" (lex destruction)	ok (Bytecode)
+						CC: need -u for OBJ,BASEOBJ,
+						UNIVERSAL,WHATEVER,main.
+						1..41, ok1-33,36-38,
+						then ok 41, ok 39.DESTROY probs
+op/regexp.t	OK		ok		ok (trivially all eval'd)
+op/repeat.t	OK		ok		ok
+op/sleep.t	OK		ok		ok
+op/sort.t	OK		ok		1..10, ok 1, Out of memory!
+op/split.t	OK		ok		ok
+op/sprintf.t	OK		ok		ok
+op/stat.t	OK		ok		ok
+op/study.t	OK		ok		ok
+op/subst.t	OK		ok		ok
+op/substr.t	OK		ok		ok1-22 except 7-9,11 (all $[)
+op/time.t	OK		ok		ok
+op/undef.t	omit 21		ok		ok
+op/unshift.t	OK		ok		ok
+op/vec.t	OK		ok		ok
+op/write.t	not ok 3 (no CvOUTSIDE lex from runtime eval). CC: 1..3, hang
diff --git a/ext/B/Todo b/ext/B/Todo
new file mode 100644
index 0000000000..495be2ef3d
--- /dev/null
+++ b/ext/B/Todo
@@ -0,0 +1,37 @@
+* Fixes
+
+CC backend: goto, sort with non-default comparison. last for non-loop blocks.
+Version checking
+improve XSUB handling (both static and dynamic)
+sv_magic can do SvREFCNT_inc(obj) which messes up precalculated refcounts
+allocation of XPV[INAHC]V structures needs fixing: Perl tries to free
+them whereas the compiler expects them to be linked to a xpv[inahc]v_root
+list the same as X[IPR]V structures.
+ref counts
+perl_parse replacement
+fix cstring for long strings
+compile-time initialisation of AvARRAYs
+signed/unsigned problems with NV (and IV?) initialisation and elsewhere?
+CvOUTSIDE for ordinary subs
+DATA filehandle for standalone Bytecode program (easy)
+DATA filehandle for multiple bytecode-compiled modules (harder)
+DATA filehandle for C-compiled program (yet harder)
+
+* Features
+
+type checking
+compile time v. runtime initialisation
+save PMOPs in compiled form
+selection of what to dump
+options for cutting out line info etc.
+comment output
+shared constants
+module dependencies
+
+* Optimisations
+collapse LISTOPs to UNOPs or BASEOPs
+compile-time qw(), constant subs
+global analysis of variables, type hints etc.
+demand-loaded bytecode (leader of each basic block replaced by an op
+which loads in bytecode for its block)
+fast sub calls for CC backend
diff --git a/ext/B/byteperl.c b/ext/B/byteperl.c
new file mode 100644
index 0000000000..c4bf6d7dd8
--- /dev/null
+++ b/ext/B/byteperl.c
@@ -0,0 +1,103 @@
+#include "EXTERN.h"
+#include "perl.h"
+#ifndef PATCHLEVEL
+#include "patchlevel.h"
+#endif
+#include "byterun.h"
+
+static void xs_init _((void));
+static PerlInterpreter *my_perl;
+
+int
+#ifndef CAN_PROTOTYPE
+main(argc, argv, env)
+int argc;
+char **argv;
+char **env;
+#else  /* def(CAN_PROTOTYPE) */
+main(int argc, char **argv, char **env)
+#endif  /* def(CAN_PROTOTYPE) */
+{
+    int exitstatus;
+    int i;
+    char **fakeargv;
+    FILE *fp;
+#ifdef INDIRECT_BGET_MACROS
+    struct bytestream bs;
+#endif /* INDIRECT_BGET_MACROS */
+
+    INIT_SPECIALSV_LIST;
+    PERL_SYS_INIT(&argc,&argv);
+ 
+#if PATCHLEVEL > 3 || (PATCHLEVEL == 3 && SUBVERSION >= 1)
+    perl_init_i18nl10n(1);
+#else
+    perl_init_i18nl14n(1);
+#endif
+
+    if (!do_undump) {
+	my_perl = perl_alloc();
+	if (!my_perl)
+	    exit(1);
+	perl_construct( my_perl );
+    }
+
+#ifdef CSH
+    if (!cshlen) 
+      cshlen = strlen(cshname);
+#endif
+
+    if (argc < 2)
+	fp = stdin;
+    else {
+#ifdef WIN32
+	fp = fopen(argv[1], "rb");
+#else
+	fp = fopen(argv[1], "r");
+#endif
+	if (!fp) {
+	    perror(argv[1]);
+	    exit(1);
+	}
+	argv++;
+	argc--;
+    }
+    New(666, fakeargv, argc + 4, char *);
+    fakeargv[0] = argv[0];
+    fakeargv[1] = "-e";
+    fakeargv[2] = "";
+    fakeargv[3] = "--";
+    for (i = 1; i < argc; i++)
+	fakeargv[i + 3] = argv[i];
+    fakeargv[argc + 3] = 0;
+    
+    exitstatus = perl_parse(my_perl, xs_init, argc + 3, fakeargv, NULL);
+    if (exitstatus)
+	exit( exitstatus );
+
+    sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
+    main_cv = compcv;
+    compcv = 0;
+
+#ifdef INDIRECT_BGET_MACROS
+    bs.data = fp;
+    bs.fgetc = (int(*) _((void*)))fgetc;
+    bs.fread = (int(*) _((char*,size_t,size_t,void*)))fread;
+    bs.freadpv = freadpv;
+    byterun(bs);
+#else    
+    byterun(fp);
+#endif /* INDIRECT_BGET_MACROS */
+    
+    exitstatus = perl_run( my_perl );
+
+    perl_destruct( my_perl );
+    perl_free( my_perl );
+
+    exit( exitstatus );
+}
+
+static void
+xs_init()
+{
+}
diff --git a/ext/B/ramblings/cc.notes b/ext/B/ramblings/cc.notes
new file mode 100644
index 0000000000..47bd65a09d
--- /dev/null
+++ b/ext/B/ramblings/cc.notes
@@ -0,0 +1,32 @@
+At entry to each basic block, the following can be assumed (and hence
+must be forced where necessary at the end of each basic block):
+
+The shadow stack @stack is empty.
+For each lexical object in @pad, VALID_IV holds for each T_INT,
+VALID_DOUBLE holds for each T_DOUBLE and VALID_SV holds otherwise.
+The C shadow variable sp holds the stack pointer (not necessarily stack_sp).
+
+write_back_stack
+    Writes the contents of the shadow stack @stack back to the real stack.
+    A write-back of each object in the stack is forced so that its
+    backing SV contains the right value and that SV is then pushed onto the
+    real stack. On return, @stack is empty.
+
+write_back_lexicals
+    Forces a write-back (i.e. achieves VALID_SV), where necessary, for each
+    lexical object in @pad. Objects with the TEMPORARY flag are skipped. If
+    write_back_lexicals is called with an (optional) argument, then it is
+    taken to be a bitmask of more flags: any lexical object with one of those
+    flags set is also skipped and not written back to its SV.
+
+invalidate_lexicals($avoid)
+    The VALID_INT and VALID_DOUBLE flags are turned off for each lexical
+    object in @pad whose flags field doesn't overlap with $avoid.
+
+reload_lexicals
+    For each necessary lexical object in @pad, makes sure that VALID_IV
+    holds for objects of type T_INT, VALID_DOUBLE holds for objects for
+    type T_DOUBLE, and VALID_SV holds for other objects. An object is
+    considered for reloading if its flags field does not overlap with the
+    (optional) argument passed to reload_lexicals.
+
diff --git a/ext/B/ramblings/curcop.runtime b/ext/B/ramblings/curcop.runtime
new file mode 100644
index 0000000000..9b8b7d52e7
--- /dev/null
+++ b/ext/B/ramblings/curcop.runtime
@@ -0,0 +1,39 @@
+PP code uses of curcop
+----------------------
+
+pp_rv2gv
+	when a new glob is created for an OPpLVAL_INTRO,
+	curcop->cop_line is stored as GvLINE() in the new GP.
+pp_bless
+	curcop->cop_stash is used as the stash in the one-arg form of bless
+
+pp_repeat
+	tests (curcop != &compiling) to warn "Can't x= to readonly value"
+
+pp_pos
+pp_substr
+pp_index
+pp_rindex
+pp_aslice
+pp_lslice
+pp_splice
+	curcop->cop_arybase
+
+pp_sort
+	curcop->cop_stash used to determine whether to gv_fetchpv $a and $b
+
+pp_caller
+	tests (curcop->cop_stash == debstash) to determine whether
+	to set DB::args
+
+pp_reset
+	resets vars in curcop->cop_stash
+
+pp_dbstate
+	sets curcop = (COP*)op
+
+doeval
+	compiles into curcop->cop_stash
+
+pp_nextstate
+	sets curcop = (COP*)op
diff --git a/ext/B/ramblings/flip-flop b/ext/B/ramblings/flip-flop
new file mode 100644
index 0000000000..183d541b98
--- /dev/null
+++ b/ext/B/ramblings/flip-flop
@@ -0,0 +1,51 @@
+PP(pp_range)
+{
+    if (GIMME == G_ARRAY)
+        return cCONDOP->op_true;
+    return SvTRUEx(PAD_SV(op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
+}
+
+pp_range is a CONDOP.
+In array context, it just returns op_true.
+In scalar context it checks the truth of targ and returns
+op_false if true, op_true if false.
+
+flip is an UNOP.
+It "looks after" its child which is always a pp_range CONDOP.
+In array context, it just returns the child's op_false.
+In scalar context, there are three possible outcomes:
+  (1) set child's targ to 1, our targ to 1 and return op_next.
+  (2) set child's targ to 1, our targ to 0, sp-- and return child's op_false.
+  (3) Blank targ and  TOPs and return op_next.
+Case 1 happens for a "..." with a matching lineno... or true TOPs.
+Case 2 happens for a ".." with a matching lineno... or true TOPs.
+Case 3 happens for a non-matching lineno or false TOPs.
+
+               $a = lhs..rhs;
+
+        ,------->  range
+        ^         /     \
+        |    true/       \false
+        |       /         \
+   first|     lhs        rhs
+        |      \   first   /
+        ^--- flip <----- flop
+                 \       /
+                  \     /
+                  sassign
+
+
+/* range */
+if (SvTRUE(curpad[op->op_targ]))
+    goto label(op_false);
+/* op_true */
+...
+/* flip */
+/* For "..." returns op_next. For ".." returns op_next or op_first->op_false */
+/* end of basic block */
+goto out;
+label(range op_false):
+...
+/* flop */
+out:
+...
diff --git a/ext/B/ramblings/magic b/ext/B/ramblings/magic
new file mode 100644
index 0000000000..e41930a0f0
--- /dev/null
+++ b/ext/B/ramblings/magic
@@ -0,0 +1,93 @@
+sv_magic()
+----------
+av.c
+av_store()
+	Storing a non-undef element into an SMAGICAL array, av,
+	assigns the equivalent lowercase form of magic (of the first
+	MAGIC in the chain) to the value (with obj = av, name = 0 and
+	namlen = array index).
+
+gv.c
+gv_init()
+	Initialising gv assigns '*' magic to it with obj = gv, name =
+	GvNAME and namlen = GvNAMELEN.
+gv_fetchpv()
+	@ISA gets 'I' magic with obj = gv, zero name and namlen.
+	%OVERLOAD gets 'A' magic with obj = gv, zero name and namlen.
+	$1 to $9, $&, $`, $', $+ get '\0' magic with obj = gv,
+	name = GvNAME and namlen = len ( = 1 presumably).
+Gv_AMupdate()
+	Stashes for overload magic seem to get 'c' magic with obj = 0,
+	name = &amt and namlen = sizeof(amt).
+hv_magic(hv, gv, how)
+	Gives magic how to hv with obj = gv and zero name and namlen.
+
+mg.c
+mg_copy(sv, nsv, key, klen)
+	Traverses the magic chain of sv. Upper case forms of magic
+	(only) are copied across to nsv, preserving obj but using
+	name = key and namlen = klen.
+magic_setpos()
+	LvTARG of a PVLV gets 'g' magic with obj = name = 0 and namlen = pos.
+
+op.c
+mod()
+	PVLV operators give magic to their targs with
+	obj = name = namlen = 0. OP_POS gives '.', OP_VEC gives 'v'
+	and OP_SUBSTR gives 'x'.
+
+perl.c
+magicname(sym, name, namlen)
+	Fetches/creates a GV with name sym and gives it '\0' magic
+	with obj = gv, name and namlen as passed.
+init_postdump_symbols()
+	Elements of the environment get given SVs with 'e' magic.
+	obj = sv and name and namlen point to the actual string
+	within env.
+
+pp.c
+pp_av2arylen()
+	$#foo gives '#' magic to the new SV with obj = av and
+	name = namlen = 0.
+pp_study()
+	SV gets 'g' magic with obj = name = namlen = 0.
+pp_substr()
+	PVLV gets 'x' magic with obj = name = namlen = 0.
+pp_vec()
+	PVLV gets 'x' magic with obj = name = namlen = 0.
+
+pp_hot.c
+pp_match()
+	m//g gets 'g' magic with obj = name = namlen = 0.
+
+pp_sys.c
+pp_tie()
+	sv gets magic with obj = sv and name = namlen = 0.
+	If an HV or an AV, it gets 'P' magic, otherwise 'q' magic.
+pp_dbmopen()
+	'P' magic for the HV just as with pp_tie().
+pp_sysread()
+	If tainting, the buffer SV gets 't' magic with
+	obj = name = namlen = 0.
+
+sv.c
+sv_setsv()
+	Doing sv_setsv(dstr, gv) gives '*' magic to dstr with
+	obj = dstr, name = GvNAME, namlen = GvNAMELEN.
+
+util.c
+fbm_compile()
+	The PVBM gets 'B' magic with obj = name = namlen = 0 and SvVALID
+	is set to indicate that the Boyer-Moore table is valid.
+	magic_setbm() just clears the SvVALID flag.
+
+hv_magic()
+----------
+
+gv.c
+gv_fetchfile()
+	With perldb, the HV of a gvfile gv gets 'L' magic with obj = gv.
+gv_fetchpv()
+	%SIG gets 'S' magic with obj = siggv.
+init_postdump_symbols()
+	%ENV gets 'E' magic with obj = envgv.
diff --git a/ext/B/ramblings/reg.alloc b/ext/B/ramblings/reg.alloc
new file mode 100644
index 0000000000..7fd69f2ebe
--- /dev/null
+++ b/ext/B/ramblings/reg.alloc
@@ -0,0 +1,32 @@
+while ($i--) {
+    foo();
+}
+exit
+
+    PP code			if i an int register	if i an int but not a
+				(i.e. can't be		register (i.e. can be
+				implicitly invalidated)	implicitly invalidated)
+    nextstate
+    enterloop
+
+							
+  loop:
+    gvsv  GV (0xe6078) *i	validates i		validates i
+    postdec			invalidates $i		invalidates $i
+    and if_false goto out;
+				i valid; $i invalid	i valid; $i invalid
+
+				i valid; $i invalid	i valid; $i invalid
+    nextstate
+    pushmark
+    gv  GV (0xe600c) *foo
+    entersub						validates $i; invals i
+
+    unstack
+    goto loop:
+
+				i valid; $i invalid
+  out:
+    leaveloop
+    nextstate
+    exit
diff --git a/ext/B/ramblings/runtime.porting b/ext/B/ramblings/runtime.porting
new file mode 100644
index 0000000000..4699b255cf
--- /dev/null
+++ b/ext/B/ramblings/runtime.porting
@@ -0,0 +1,350 @@
+Notes on porting the perl runtime PP engine.
+Importance: 1 = who cares?, 10 = vital
+Difficulty: 1 = trivial, 10 = very difficult. Level assumes a
+reasonable implementation of the SV and OP API already ported.
+
+OP		Import	Diff	Comments
+null		10	1
+stub		10	1
+scalar		10	1
+pushmark	10	1	PUSHMARK
+wantarray	7	3	cxstack, dopoptosub
+const		10	1	
+gvsv		10	1	save_scalar
+gv		10	1	
+gelem		3	3	
+padsv		10	2	SAVECLEARSV, provide_ref
+padav		10	2
+padhv		10	2
+padany		1	1
+pushre		7	3	pushes an op. Blech.
+rv2gv		6	5
+rv2sv		10	4
+av2arylen	7	3	sv_magic	
+rv2cv		8	5	sv_2cv
+anoncode	7	6	cv_clone
+prototype	4	4	sv_2cv
+refgen		8	3
+srefgen		8	2
+ref		8	3
+bless		7	3
+backtick	5	4
+glob		5	2	do_readline
+readline	8	2	do_readline	
+rcatline	8	2
+regcmaybe	8	1
+regcomp		8	9	pregcomp
+match		8	10
+subst		8	10
+substcont	8	7
+trans		7	4	do_trans
+sassign		10	3	mg_find, SvSETMAGIC
+aassign		10	5	
+chop		8	3	do_chop
+schop		8	3	do_chop
+chomp		8	3	do_chomp
+schomp		8	3	do_chomp
+defined		10	2
+undef		10	3
+study		4	5
+pos		8	3	PVLV, mg_find
+preinc		10	2	sv_inc, SvSETMAGIC
+i_preinc
+predec		10	2	sv_dec, SvSETMAGIC
+i_predec
+postinc		10	2	sv_dec, SvSETMAGIC
+i_postinc
+postdec		10	2	sv_dec, SvSETMAGIC
+i_postdec
+pow		10	1
+multiply	10	1
+i_multiply	10	1
+divide		10	2
+i_divide	10	1
+modulo		10	2
+i_modulo	10	1
+repeat		6	4
+add		10	1
+i_add		10	1
+subtract	10	1
+i_subtract	10	1
+concat		10	2	mg_get
+stringify	10	2	sv_setpvn
+left_shift	10	1
+right_shift	10	1
+lt		10	1
+i_lt		10	1
+gt		10	1
+i_gt		10	1
+le		10	1
+i_le		10	1
+ge		10	1
+i_ge		10	1
+eq		10	1
+i_eq		10	1
+ne		10	1
+i_ne		10	1
+ncmp		10	1
+i_ncmp		10	1
+slt		10	2
+sgt		10	2
+sle		10	2
+sge		10	2
+seq		10	2	sv_eq
+sne		10	2
+scmp		10	2
+bit_and		10	2
+bit_xor		10	2
+bit_or		10	2
+negate		10	3
+i_negate	10	1
+not		10	1
+complement	10	3
+atan2		6	1
+sin		6	1
+cos		6	1
+rand		5	2
+srand		5	2
+exp		6	1
+log		6	2
+sqrt		6	2
+int		10	2
+hex		9	2
+oct		9	2
+abs		10	1
+length		10	1
+substr		10	4	PVLV
+vec		5	4
+index		9	3
+rindex		9	3
+sprintf		9	4	do_sprintf
+formline	6	7
+ord		6	2	
+chr		6	2
+crypt		3	2
+ucfirst		6	2
+lcfirst		6	2
+uc		6	2
+lc		6	2
+quotemeta	6	3
+rv2av		10	3	save_svref, mg_get, save_ary
+aelemfast	10	2	av_fetch
+aelem		10	3
+aslice		9	4
+each		10	3	hv_iternext
+values		10	3	do_kv
+keys		10	3	do_kv
+delete		10	3
+exists		10	3
+rv2hv		10	3	save_svref, mg_get, save_ary, do_kv
+helem		10	3	save_svref, provide_ref
+hslice		9	4
+unpack		9	6	lengthy
+pack		9	6	lengthy
+split		9	9
+join		10	4	do_join
+list		10	2
+lslice		9	4
+anonlist	10	2
+anonhash	10	3
+splice		9	6
+push		10	2
+pop		10	2
+shift		10	2
+unshift		10	2
+sort		6	7
+reverse		9	4
+grepstart	6	5	modifies flow of control
+grepwhile	6	5	modifies flow of control
+mapstart	1	1
+mapwhile	6	5	modifies flow of control
+range		7	3	modifies flow of control
+flip		7	4	modifies flow of control
+flop		7	4	modifies flow of control
+and		10	3	modifies flow of control
+or		10	3	modifies flow of control
+xor
+cond_expr	10	3	modifies flow of control
+andassign	7	3	modifies flow of control
+orassign	7	3	modifies flow of control
+method		8	5
+entersub	10	7
+leavesub	10	5
+caller		2	8
+warn		9	3
+die		9	3
+reset		2	2
+lineseq		1	1
+nextstate	10	1	Update stack_sp from cxstack. FREETMPS.
+dbstate		3	7		
+unstack
+enter		10	3	cxstack, ENTER, SAVETMPS, PUSHBLOCK
+leave		10	3	cxstack, SAVETMPS, LEAVE, POPBLOCK
+scope		1	1
+enteriter	9	4	cxstack
+iter		9	3	cxstack
+enterloop	10	4
+leaveloop	10	4
+return		10	5
+last		9	6
+next		9	6
+redo		9	6
+dump		1	9	pp_goto
+goto		6	9
+exit		9	2	my_exit
+open		9	5	do_open
+close		9	3	do_close
+pipe_op		7	4
+fileno		9	2
+umask		4	2
+binmode		4	2
+tie		5	5	pp_entersub
+untie		5	2	sv_unmagic
+tied		5	2
+dbmopen		4	5
+dbmclose	4	2
+sselect		4	4
+select		7	3
+getc		7	2
+read		8	2	pp_sysread
+enterwrite	4	4	doform
+leavewrite	4	5
+prtf		4	4	do_sprintf
+print		8	6
+sysopen		8	2
+sysread		8	4
+syswrite	8	4	pp_send
+send		8	4
+recv		8	4	pp_sysread
+eof		9	2
+tell		9	3
+seek		9	2
+truncate	8	3
+fcntl		8	4	pp_ioctl
+ioctl		8	4
+flock		8	2
+socket		5	3
+sockpair	5	3
+bind		5	3
+connect		5	3
+listen		5	3
+accept		5	3
+shutdown	5	2
+gsockopt	5	3	pp_ssockopt
+ssockopt	5	3
+getsockname	5	3	pp_getpeername
+getpeername	5	3
+lstat		5	4	pp_stat
+stat		5	4	lengthy
+ftrread		5	2	cando
+ftrwrite	5	2	cando
+ftrexec		5	2	cando
+fteread		5	2	cando
+ftewrite	5	2	cando
+fteexec		5	2	cando
+ftis		5	2	cando
+fteowned	5	2	cando
+ftrowned	5	2	cando
+ftzero		5	2	cando
+ftsize		5	2	cando
+ftmtime		5	2	cando
+ftatime		5	2	cando
+ftctime		5	2	cando
+ftsock		5	2	cando
+ftchr		5	2	cando
+ftblk		5	2	cando
+ftfile		5	2	cando
+ftdir		5	2	cando
+ftpipe		5	2	cando
+ftlink		5	2	cando
+ftsuid		5	2	cando
+ftsgid		5	2	cando
+ftsvtx		5	2	cando
+fttty		5	2	cando
+fttext		5	4
+ftbinary	5	4	fttext
+chdir
+chown
+chroot
+unlink
+chmod
+utime
+rename
+link
+symlink
+readlink
+mkdir
+rmdir
+open_dir
+readdir
+telldir
+seekdir
+rewinddir
+closedir
+fork
+wait
+waitpid
+system
+exec
+kill
+getppid
+getpgrp
+setpgrp
+getpriority
+setpriority
+time
+tms
+localtime
+gmtime
+alarm
+sleep
+shmget
+shmctl
+shmread
+shmwrite
+msgget
+msgctl
+msgsnd
+msgrcv
+semget
+semctl
+semop
+require		6	9	doeval
+dofile		6	9	doeval
+entereval	6	9	doeval
+leaveeval	6	5
+entertry	7	4	modifies flow of control
+leavetry	7	3
+ghbyname
+ghbyaddr
+ghostent
+gnbyname
+gnbyaddr
+gnetent
+gpbyname
+gpbynumber
+gprotoent
+gsbyname
+gsbyport
+gservent
+shostent
+snetent
+sprotoent
+sservent
+ehostent
+enetent
+eprotoent
+eservent
+gpwnam
+gpwuid
+gpwent
+spwent
+epwent
+ggrnam
+ggrgid
+ggrent
+sgrent
+egrent
+getlogin
+syscall
+	
\ No newline at end of file
diff --git a/ext/B/typemap b/ext/B/typemap
new file mode 100644
index 0000000000..7206a6a2e1
--- /dev/null
+++ b/ext/B/typemap
@@ -0,0 +1,69 @@
+TYPEMAP
+
+B::OP		T_OP_OBJ
+B::UNOP		T_OP_OBJ
+B::BINOP	T_OP_OBJ
+B::LOGOP	T_OP_OBJ
+B::CONDOP	T_OP_OBJ
+B::LISTOP	T_OP_OBJ
+B::PMOP		T_OP_OBJ
+B::SVOP		T_OP_OBJ
+B::GVOP		T_OP_OBJ
+B::PVOP		T_OP_OBJ
+B::CVOP		T_OP_OBJ
+B::LOOP		T_OP_OBJ
+B::COP		T_OP_OBJ
+
+B::SV		T_SV_OBJ
+B::PV		T_SV_OBJ
+B::IV		T_SV_OBJ
+B::NV		T_SV_OBJ
+B::PVMG		T_SV_OBJ
+B::PVLV		T_SV_OBJ
+B::BM		T_SV_OBJ
+B::RV		T_SV_OBJ
+B::GV		T_SV_OBJ
+B::CV		T_SV_OBJ
+B::HV		T_SV_OBJ
+B::AV		T_SV_OBJ
+B::IO		T_SV_OBJ
+
+B::MAGIC	T_MG_OBJ
+SSize_t		T_IV
+STRLEN		T_IV
+
+INPUT
+T_OP_OBJ
+	if (SvROK($arg)) {
+	    IV tmp = SvIV((SV*)SvRV($arg));
+	    $var = ($type) tmp;
+	}
+	else
+	    croak(\"$var is not a reference\")
+
+T_SV_OBJ
+	if (SvROK($arg)) {
+	    IV tmp = SvIV((SV*)SvRV($arg));
+	    $var = ($type) tmp;
+	}
+	else
+	    croak(\"$var is not a reference\")
+
+T_MG_OBJ
+	if (SvROK($arg)) {
+	    IV tmp = SvIV((SV*)SvRV($arg));
+	    $var = ($type) tmp;
+	}
+	else
+	    croak(\"$var is not a reference\")
+
+OUTPUT
+T_OP_OBJ
+	sv_setiv(newSVrv($arg, cc_opclassname((OP*)$var)), (IV)$var);
+
+T_SV_OBJ
+	make_sv_object(($arg), (SV*)($var));
+
+
+T_MG_OBJ
+	sv_setiv(newSVrv($arg, "B::MAGIC"), (IV)$var);
diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs
index 91b4dc2ad5..b6da38609d 100644
--- a/ext/DB_File/DB_File.xs
+++ b/ext/DB_File/DB_File.xs
@@ -533,6 +533,14 @@ DB_File db ;
     DBT_flags(key) ;
     DBT_flags(value) ;
     RETVAL = do_SEQ(db, key, value, R_LAST) ;
+    if (RETVAL < 0 && errno == EBADF)
+     {                
+      recno_t oops = -1;
+      key.data = &oops; 
+      key.size = sizeof(oops);
+      db_get(db, key, value, 0);
+      RETVAL = do_SEQ(db, key, value, R_LAST) ;
+     }
     if (RETVAL == 0)
         RETVAL = *(I32 *)key.data ;
     else /* No key means empty file */
diff --git a/ext/Thread/Thread.pm b/ext/Thread/Thread.pm
index 48ca3047b9..cf7069c45d 100644
--- a/ext/Thread/Thread.pm
+++ b/ext/Thread/Thread.pm
@@ -8,6 +8,38 @@ $VERSION = "1.0";
 @ISA = qw(Exporter DynaLoader);
 @EXPORT_OK = qw(yield cond_signal cond_broadcast cond_wait async);
 
+=head1 NAME
+
+Thread - multithreading
+
+=head1 SYNOPSIS
+
+    use Thread;
+
+    my $t = new Thread \&start_sub, @start_args;
+
+    $t->join;
+
+    my $tid = Thread->self->tid; 
+
+    my $tlist = Thread->list;
+
+    lock($scalar);
+
+    use Thread 'async';
+
+    use Thread 'eval';
+
+=head1 DESCRIPTION
+
+The C<Threads> module provides multithreading.
+
+=head1 SEE ALSO
+
+L<attrs>, L<Thread::Queue>, L<Thread::Semaphore>, L<Thread::Specific>.
+
+=cut
+
 #
 # Methods
 #
diff --git a/ext/Thread/Thread/Queue.pm b/ext/Thread/Thread/Queue.pm
index 4eef978bd6..9821773aa4 100644
--- a/ext/Thread/Thread/Queue.pm
+++ b/ext/Thread/Thread/Queue.pm
@@ -1,6 +1,19 @@
 package Thread::Queue;
 use Thread qw(cond_wait cond_broadcast);
 
+=head1 NAME
+
+Thread::Queue - thread-safe queues
+
+=head1 SYNOPSIS
+
+    use Thread::Queue;
+    my $q = new Thread::Queue;
+    $q->enqueue("foo", "bar");
+    my $foo = $q->dequeue;	# The "bar" is still in the queue.
+
+=cut
+
 sub new {
     my $class = shift;
     return bless [@_], $class;
diff --git a/ext/Thread/Thread/Semaphore.pm b/ext/Thread/Thread/Semaphore.pm
index 9e5852f15c..4e1bb7ddbc 100644
--- a/ext/Thread/Thread/Semaphore.pm
+++ b/ext/Thread/Thread/Semaphore.pm
@@ -1,6 +1,25 @@
 package Thread::Semaphore;
 use Thread qw(cond_wait cond_broadcast);
 
+=head1 NAME
+
+Thread::Semaphore - thread-safe semaphores
+
+=head1 SYNOPSIS
+
+    use Thread::Semaphore;
+    my $s = new Thread::Semaphore;
+    $s->up;	# Also known as the semaphore V -operation.
+    # The guarded section is here
+    $s->down;	# Also known as the semaphore P -operation.
+
+    # The default semaphore value is 1.
+    my $s = new Thread::Semaphore($initial_value);
+    $s->up($up_value);
+    $s->down($up_value);
+
+=cut
+
 sub new {
     my $class = shift;
     my $val = @_ ? shift : 1;
diff --git a/ext/Thread/Thread/Specific.pm b/ext/Thread/Thread/Specific.pm
index ec56539e40..c3591f4b94 100644
--- a/ext/Thread/Thread/Specific.pm
+++ b/ext/Thread/Thread/Specific.pm
@@ -1,5 +1,16 @@
 package Thread::Specific;
 
+=head1 NAME
+
+Thread::Specific - thread-specific keys
+
+=head1 SYNOPSIS
+
+    use Thread::Specific;
+    my $k = key_create Thread::Specific;
+
+=cut
+
 sub import {
     use attrs qw(locked method);
     require fields;