B, B::C, perlcc, t/TEST

Message-ID: <3C38389E.7831.493570@localhost>

p4raw-id: //depot/perl@14104

5 files changed, 723 insertions, 151 deletions

diff --git a/ext/B/B.xs b/ext/B/B.xs
index 491c640c68..f18efce96d 100644
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -74,7 +74,7 @@ static char *opclassnames[] = {
 
 typedef struct {
     int		x_walkoptree_debug;	/* Flag for walkoptree debug hook */
-    SV *	x_specialsv_list[6];
+    SV *	x_specialsv_list[7];
 } my_cxt_t;
 
 START_MY_CXT
@@ -229,6 +229,7 @@ cstring(pTHX_ SV *sv)
     SV *sstr = newSVpvn("", 0);
     STRLEN len;
     char *s;
+    char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
 
     if (!SvOK(sv))
 	sv_setpvn(sstr, "0", 1);
@@ -244,6 +245,12 @@ cstring(pTHX_ SV *sv)
 		sv_catpv(sstr, "\\\"");
 	    else if (*s == '\\')
 		sv_catpv(sstr, "\\\\");
+            /* trigraphs - bleagh */
+            else if (*s == '?' && len>=3 && s[1] == '?')
+            {
+                sprintf(escbuff, "\\%03o", '?');
+                sv_catpv(sstr, escbuff);
+            }
 	    else if (*s >= ' ' && *s < 127) /* XXX not portable */
 		sv_catpvn(sstr, s, 1);
 	    else if (*s == '\n')
@@ -262,8 +269,6 @@ cstring(pTHX_ SV *sv)
 		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);
@@ -390,6 +395,7 @@ BOOT:
     specialsv_list[3] = &PL_sv_no;
     specialsv_list[4] = pWARN_ALL;
     specialsv_list[5] = pWARN_NONE;
+    specialsv_list[6] = pWARN_STD;
 #include "defsubs.h"
 }
 
@@ -919,13 +925,33 @@ char*
 SvPVX(sv)
 	B::PV	sv
 
+B::SV
+SvRV(sv)
+        B::PV   sv
+    CODE:
+        if( SvROK(sv) ) {
+            RETVAL = SvRV(sv);
+        }
+        else {
+            croak( "argument is not SvROK" );
+        }
+    OUTPUT:
+        RETVAL
+
 void
 SvPV(sv)
 	B::PV	sv
     CODE:
-	ST(0) = sv_newmortal();
-	sv_setpvn(ST(0), SvPVX(sv), SvCUR(sv));
-	SvFLAGS(ST(0)) |= SvUTF8(sv);
+        ST(0) = sv_newmortal();
+        if( SvPOK(sv) ) {
+            sv_setpvn(ST(0), SvPVX(sv), SvCUR(sv));
+            SvFLAGS(ST(0)) |= SvUTF8(sv);
+        }
+        else {
+            /* XXX for backward compatibility, but should fail */
+            /* croak( "argument is not SvPOK" ); */
+            sv_setpvn(ST(0), NULL, 0);
+        }
 
 STRLEN
 SvLEN(sv)
@@ -979,6 +1005,30 @@ MgFLAGS(mg)
 B::SV
 MgOBJ(mg)
 	B::MAGIC	mg
+    CODE:
+        if( mg->mg_type != 'r' ) {
+            RETVAL = MgOBJ(mg);
+        }
+        else {
+            croak( "OBJ is not meaningful on r-magic" );
+        }
+    OUTPUT:
+        RETVAL
+
+SV*
+precomp(mg)
+        B::MAGIC        mg
+    CODE:
+        if (mg->mg_type == 'r') {
+            REGEXP* rx = (REGEXP*)mg->mg_obj;
+            if( rx )
+                RETVAL = newSVpvn( rx->precomp, rx->prelen );
+        }
+        else {
+            croak( "precomp is only meaningful on r-magic" );
+        }
+    OUTPUT:
+        RETVAL
 
 I32 
 MgLENGTH(mg)
@@ -1160,6 +1210,29 @@ short
 IoSUBPROCESS(io)
 	B::IO	io
 
+bool
+IsSTD(io,name)
+	B::IO	io
+	char*	name
+    PREINIT:
+	PerlIO* handle = 0;
+    CODE:
+	if( strEQ( name, "stdin" ) ) {
+	    handle = PerlIO_stdin();
+	}
+	else if( strEQ( name, "stdout" ) ) {
+	    handle = PerlIO_stdout();
+	}
+	else if( strEQ( name, "stderr" ) ) {
+	    handle = PerlIO_stderr();
+	}
+	else {
+	    croak( "Invalid value '%s'", name );
+	}
+	RETVAL = handle == IoIFP(io);
+    OUTPUT:
+	RETVAL
+
 MODULE = B	PACKAGE = B::IO
 
 char
@@ -1248,7 +1321,9 @@ void
 CvXSUBANY(cv)
 	B::CV	cv
     CODE:
-	ST(0) = sv_2mortal(newSViv(CvXSUBANY(cv).any_iv));
+	ST(0) = CvCONST(cv) ?
+                    make_sv_object(aTHX_ sv_newmortal(),CvXSUBANY(cv).any_ptr) :
+                    sv_2mortal(newSViv(CvXSUBANY(cv).any_iv));
 
 MODULE = B    PACKAGE = B::CV
 
diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm
index d3c9f5b05d..fd7c1a9c93 100644
--- a/ext/B/B/C.pm
+++ b/ext/B/B/C.pm
@@ -7,7 +7,7 @@
 #
 package B::C::Section;
 
-our $VERSION = '1.00';
+our $VERSION = '1.01';
 
 use B ();
 use base B::Section;
@@ -16,34 +16,67 @@ sub new
 {
  my $class = shift;
  my $o = $class->SUPER::new(@_);
- push(@$o,[]);
+ push @$o, { values => [] };
  return $o;
 }
 
 sub add
-{  
+{
  my $section = shift;
- push(@{$section->[-1]},@_);
+ push(@{$section->[-1]{values}},@_);
 }
 
 sub index
-{  
+{
  my $section = shift;
- return scalar(@{$section->[-1]})-1;
+ return scalar(@{$section->[-1]{values}})-1;
 }
 
 sub output
-{   
+{
  my ($section, $fh, $format) = @_;
  my $sym = $section->symtable || {};
  my $default = $section->default;
- foreach (@{$section->[-1]})
+ foreach (@{$section->[-1]{values}})
   {
    s{(s\\_[0-9a-f]+)}{ exists($sym->{$1}) ? $sym->{$1} : $default; }ge;
    printf $fh $format, $_;
   }
 }
 
+package B::C::InitSection;
+
+use vars qw(@ISA); @ISA = qw(B::C::Section);
+
+sub new {
+    my $class = shift;
+    my $section = $class->SUPER::new( @_ );
+
+    $section->[-1]{evals} = [];
+
+    return $section;
+}
+
+sub add_eval {
+    my $section = shift;
+    my @strings = @_;
+
+    foreach my $i ( @strings ) {
+        $i =~ s/\"/\\\"/g;
+    }
+    push @{$section->[-1]{evals}}, @strings;
+}
+
+sub output {
+    my $section = shift;
+
+    foreach my $i ( @{$section->[-1]{evals}} ) {
+        $section->add( sprintf q{eval_pv("%s",1);}, $i );
+    }
+    $section->SUPER::output( @_ );
+}
+
+
 package B::C;
 use Exporter ();
 @ISA = qw(Exporter);
@@ -52,8 +85,8 @@ use Exporter ();
 
 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 main_cv init_av opnumber amagic_generation
-	 AVf_REAL HEf_SVKEY);
+	 threadsv_names main_cv init_av end_av opnumber amagic_generation
+	 AVf_REAL HEf_SVKEY SVf_POK SVf_ROK CVf_CONST);
 use B::Asmdata qw(@specialsv_name);
 
 use FileHandle;
@@ -65,6 +98,7 @@ my $hv_index = 0;
 my $gv_index = 0;
 my $re_index = 0;
 my $pv_index = 0;
+my $cv_index = 0;
 my $anonsub_index = 0;
 my $initsub_index = 0;
 
@@ -73,8 +107,14 @@ my %xsub;
 my $warn_undefined_syms;
 my $verbose;
 my %unused_sub_packages;
+my $use_xsloader;
 my $nullop_count;
 my $pv_copy_on_grow = 0;
+my $optimize_ppaddr = 0;
+my $optimize_warn_sv = 0;
+my $use_perl_script_name = 0;
+my $save_data_fh = 0;
+my $save_sig = 0;
 my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
 my $max_string_len;
 
@@ -89,6 +129,9 @@ my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect,
     $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
     $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
     $xrvsect, $xpvbmsect, $xpviosect );
+my @op_sections = \( $binopsect, $condopsect, $copsect, $padopsect, $listopsect,
+                     $logopsect, $loopsect, $opsect, $pmopsect, $pvopsect, $svopsect,
+                     $unopsect );
 
 sub walk_and_save_optree;
 my $saveoptree_callback = \&walk_and_save_optree;
@@ -139,6 +182,14 @@ sub getsym {
     }
 }
 
+sub savere {
+    my $re = shift;
+    my $sym = sprintf("re%d", $re_index++);
+    $decl->add(sprintf("static char *$sym = %s;", cstring($re)));
+
+    return ($sym,length(pack "a*",$re));
+}
+
 sub savepv {
     my $pv = shift;         
     $pv    = '' unless defined $pv;  # Is this sane ?
@@ -151,11 +202,50 @@ sub savepv {
 	    $decl->add(sprintf("static char %s[] = %s;", $pvsym, $cstring));
 	}
     } else {
-	$pvmax = length($pv) + 1;
+	$pvmax = length(pack "a*",$pv) + 1;
     }
     return ($pvsym, $pvmax);
 }
 
+sub save_rv {
+    my $sv = shift;
+#    confess "Can't save RV: not ROK" unless $sv->FLAGS & SVf_ROK;
+    my $rv = $sv->RV->save;
+
+    $rv =~ s/^\(([AGHS]V|IO)\s*\*\)\s*(\&sv_list.*)$/$2/;
+
+    return $rv;
+}
+
+# savesym, pvmax, len, pv
+sub save_pv_or_rv {
+    my $sv = shift;
+
+    my $rok = $sv->FLAGS & SVf_ROK;
+    my $pok = $sv->FLAGS & SVf_POK;
+    my( $pv, $len, $savesym, $pvmax );
+    if( $rok ) {
+       $savesym = '(char*)' . save_rv( $sv );
+    }
+    else {
+       $pv = $pok ? (pack "a*", $sv->PV) : undef;
+       $len = $pok ? length($pv) : 0;
+       ($savesym, $pvmax) = $pok ? savepv($pv) : ( 'NULL', 0 );
+    }
+
+    return ( $savesym, $pvmax, $len, $pv );
+}
+
+# see also init_op_ppaddr below; initializes the ppaddt to the
+# OpTYPE; init_op_ppaddr iterates over the ops and sets
+# op_ppaddr to PL_ppaddr[op_ppaddr]; this avoids an explicit assignmente
+# in perl_init ( ~10 bytes/op with GCC/i386 )
+sub B::OP::fake_ppaddr {
+    return $optimize_ppaddr ?
+      sprintf("INT2PTR(void*,OP_%s)", uc( $_[0]->name ) ) :
+      'NULL';
+}
+
 sub B::OP::save {
     my ($op, $level) = @_;
     my $sym = objsym($op);
@@ -167,11 +257,12 @@ sub B::OP::save {
 	$init->add(sprintf("(void)find_threadsv(%s);",
 			   cstring($threadsv_names[$op->targ])));
     }
-    $opsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x",
-			 ${$op->next}, ${$op->sibling}, $op->targ,
+    $opsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x",
+			 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, $op->targ,
 			 $type, $op_seq, $op->flags, $op->private));
     my $ix = $opsect->index;
-    $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr));
+    $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr))
+        unless $optimize_ppaddr;
     savesym($op, "&op_list[$ix]");
 }
 
@@ -182,11 +273,12 @@ sub B::FAKEOP::new {
 
 sub B::FAKEOP::save {
     my ($op, $level) = @_;
-    $opsect->add(sprintf("%s, %s, NULL, %u, %u, %u, 0x%x, 0x%x",
-			 $op->next, $op->sibling, $op->targ,
+    $opsect->add(sprintf("%s, %s, %s, %u, %u, %u, 0x%x, 0x%x",
+			 $op->next, $op->sibling, $op->fake_ppaddr, $op->targ,
 			 $op->type, $op_seq, $op->flags, $op->private));
     my $ix = $opsect->index;
-    $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr));
+    $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr))
+        unless $optimize_ppaddr;
     return "&op_list[$ix]";
 }
 
@@ -202,12 +294,13 @@ sub B::UNOP::save {
     my ($op, $level) = @_;
     my $sym = objsym($op);
     return $sym if defined $sym;
-    $unopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x",
-			   ${$op->next}, ${$op->sibling},
+    $unopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x",
+			   ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
 			   $op->targ, $op->type, $op_seq, $op->flags,
 			   $op->private, ${$op->first}));
     my $ix = $unopsect->index;
-    $init->add(sprintf("unop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
+    $init->add(sprintf("unop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
+        unless $optimize_ppaddr;
     savesym($op, "(OP*)&unop_list[$ix]");
 }
 
@@ -215,12 +308,13 @@ sub B::BINOP::save {
     my ($op, $level) = @_;
     my $sym = objsym($op);
     return $sym if defined $sym;
-    $binopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
-			    ${$op->next}, ${$op->sibling},
+    $binopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
+			    ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
 			    $op->targ, $op->type, $op_seq, $op->flags,
 			    $op->private, ${$op->first}, ${$op->last}));
     my $ix = $binopsect->index;
-    $init->add(sprintf("binop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
+    $init->add(sprintf("binop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
+        unless $optimize_ppaddr;
     savesym($op, "(OP*)&binop_list[$ix]");
 }
 
@@ -228,12 +322,13 @@ sub B::LISTOP::save {
     my ($op, $level) = @_;
     my $sym = objsym($op);
     return $sym if defined $sym;
-    $listopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
-			     ${$op->next}, ${$op->sibling},
+    $listopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
+			     ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
 			     $op->targ, $op->type, $op_seq, $op->flags,
 			     $op->private, ${$op->first}, ${$op->last}));
     my $ix = $listopsect->index;
-    $init->add(sprintf("listop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
+    $init->add(sprintf("listop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
+        unless $optimize_ppaddr;
     savesym($op, "(OP*)&listop_list[$ix]");
 }
 
@@ -241,12 +336,13 @@ sub B::LOGOP::save {
     my ($op, $level) = @_;
     my $sym = objsym($op);
     return $sym if defined $sym;
-    $logopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
-			    ${$op->next}, ${$op->sibling},
+    $logopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
+			    ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
 			    $op->targ, $op->type, $op_seq, $op->flags,
 			    $op->private, ${$op->first}, ${$op->other}));
     my $ix = $logopsect->index;
-    $init->add(sprintf("logop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
+    $init->add(sprintf("logop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
+        unless $optimize_ppaddr;
     savesym($op, "(OP*)&logop_list[$ix]");
 }
 
@@ -257,14 +353,15 @@ sub B::LOOP::save {
     #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, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x",
-			   ${$op->next}, ${$op->sibling},
+    $loopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x",
+			   ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
 			   $op->targ, $op->type, $op_seq, $op->flags,
 			   $op->private, ${$op->first}, ${$op->last},
 			   ${$op->redoop}, ${$op->nextop},
 			   ${$op->lastop}));
     my $ix = $loopsect->index;
-    $init->add(sprintf("loop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
+    $init->add(sprintf("loop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
+        unless $optimize_ppaddr;
     savesym($op, "(OP*)&loop_list[$ix]");
 }
 
@@ -272,12 +369,13 @@ sub B::PVOP::save {
     my ($op, $level) = @_;
     my $sym = objsym($op);
     return $sym if defined $sym;
-    $pvopsect->add(sprintf("s\\_%x, s\\_%x, NULL,  %u, %u, %u, 0x%x, 0x%x, %s",
-			   ${$op->next}, ${$op->sibling},
+    $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s,  %u, %u, %u, 0x%x, 0x%x, %s",
+			   ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
 			   $op->targ, $op->type, $op_seq, $op->flags,
 			   $op->private, cstring($op->pv)));
     my $ix = $pvopsect->index;
-    $init->add(sprintf("pvop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
+    $init->add(sprintf("pvop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
+        unless $optimize_ppaddr;
     savesym($op, "(OP*)&pvop_list[$ix]");
 }
 
@@ -286,12 +384,13 @@ sub B::SVOP::save {
     my $sym = objsym($op);
     return $sym if defined $sym;
     my $svsym = $op->sv->save;
-    $svopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, Nullsv",
-			   ${$op->next}, ${$op->sibling},
+    $svopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, Nullsv",
+			   ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
 			   $op->targ, $op->type, $op_seq, $op->flags,
 			   $op->private));
     my $ix = $svopsect->index;
-    $init->add(sprintf("svop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
+    $init->add(sprintf("svop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
+        unless $optimize_ppaddr;
     $init->add("svop_list[$ix].op_sv = (SV*)$svsym;");
     savesym($op, "(OP*)&svop_list[$ix]");
 }
@@ -300,12 +399,13 @@ sub B::PADOP::save {
     my ($op, $level) = @_;
     my $sym = objsym($op);
     return $sym if defined $sym;
-    $padopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, 0",
-			   ${$op->next}, ${$op->sibling},
+    $padopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, 0",
+			   ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
 			   $op->targ, $op->type, $op_seq, $op->flags,
 			   $op->private));
-    $init->add(sprintf("padop_list[%d].op_ppaddr = %s;", $padopsect->index, $op->ppaddr));
     my $ix = $padopsect->index;
+    $init->add(sprintf("padop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
+        unless $optimize_ppaddr;
     $init->add(sprintf("padop_list[$ix].op_padix = %ld;", $op->padix));
     savesym($op, "(OP*)&padop_list[$ix]");
 }
@@ -316,15 +416,47 @@ sub B::COP::save {
     return $sym if defined $sym;
     warn sprintf("COP: line %d file %s\n", $op->line, $op->file)
 	if $debug_cops;
-    $copsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, %s, NULL, NULL, %u, %d, %u",
-			  ${$op->next}, ${$op->sibling},
+    # shameless cut'n'paste from B::Deparse
+    my $warn_sv;
+    my $warnings = $op->warnings;
+    my $is_special = $warnings->isa("B::SPECIAL");
+    if ($is_special && $$warnings == 4) {
+        # use warnings 'all';
+        $warn_sv = $optimize_warn_sv ?
+            'INT2PTR(SV*,1)' :
+            'pWARN_ALL';
+    }
+    elsif ($is_special && $$warnings == 5) {
+        # no warnings 'all';
+        $warn_sv = $optimize_warn_sv ?
+            'INT2PTR(SV*,1)' :
+            'pWARN_NONE';
+    }
+    elsif ($is_special) {
+        # use warnings;
+        $warn_sv = $optimize_warn_sv ?
+            'INT2PTR(SV*,1)' :
+            'pWARN_STD';
+    }
+    else {
+        # something else
+        $warn_sv = $warnings->save;
+    }
+
+    $copsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s, NULL, NULL, %u, %d, %u, %s",
+			  ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
 			  $op->targ, $op->type, $op_seq, $op->flags,
 			  $op->private, cstring($op->label), $op->cop_seq,
-			  $op->arybase, $op->line));
+			  $op->arybase, $op->line,
+                          ( $optimize_warn_sv ? $warn_sv : 'NULL' )));
     my $ix = $copsect->index;
-    $init->add(sprintf("cop_list[$ix].op_ppaddr = %s;", $op->ppaddr));
+    $init->add(sprintf("cop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
+        unless $optimize_ppaddr;
+    $init->add(sprintf("cop_list[$ix].cop_warnings = %s;", $warn_sv ))
+        unless $optimize_warn_sv;
     $init->add(sprintf("CopFILE_set(&cop_list[$ix], %s);", cstring($op->file)),
 	       sprintf("CopSTASHPV_set(&cop_list[$ix], %s);", cstring($op->stashpv)));
+
     savesym($op, "(OP*)&cop_list[$ix]");
 }
 
@@ -353,20 +485,20 @@ sub B::PMOP::save {
     # 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, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %s, %s, 0, 0, 0x%x, 0x%x",
-			   ${$op->next}, ${$op->sibling}, $op->targ,
+    $pmopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %s, %s, 0, 0, 0x%x, 0x%x",
+			   ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, $op->targ,
 			   $op->type, $op_seq, $op->flags, $op->private,
 			   ${$op->first}, ${$op->last}, 
 			   $replrootfield, $replstartfield,
 			   $op->pmflags, $op->pmpermflags,));
     my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
-    $init->add(sprintf("$pm.op_ppaddr = %s;", $ppaddr));
+    $init->add(sprintf("$pm.op_ppaddr = %s;", $ppaddr))
+        unless $optimize_ppaddr;
     my $re = $op->precomp;
     if (defined($re)) {
-	my $resym = sprintf("re%d", $re_index++);
-	$decl->add(sprintf("static char *$resym = %s;", cstring($re)));
+	my( $resym, $relen ) = savere( $re );
 	$init->add(sprintf("PM_SETRE(&$pm,pregcomp($resym, $resym + %u, &$pm));",
-			   length($re)));
+			   $relen));
     }
     if ($gvsym) {
 	$init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
@@ -395,7 +527,7 @@ sub B::NULL::save {
     # debug
     if ($$sv == 0) {
     	warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
-	return savesym($sv, "Nullsv /* XXX */");
+	return savesym($sv, "(void*)Nullsv /* XXX */");
     }
     $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT , $sv->FLAGS));
     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
@@ -426,6 +558,8 @@ sub B::NV::save {
 sub savepvn {
     my ($dest,$pv) = @_;
     my @res;
+    # work with byte offsets/lengths
+    my $pv = pack "a*", $pv;
     if (defined $max_string_len && length($pv) > $max_string_len) {
 	push @res, sprintf("New(0,%s,%u,char);", $dest, length($pv)+1);
 	my $offset = 0;
@@ -469,13 +603,11 @@ 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));
+    my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
+    $xpvivsect->add(sprintf("%s, %u, %u, %d", $savesym, $len, $pvmax, $sv->IVX));
     $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
 			 $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
-    if (!$pv_copy_on_grow) {
+    if (defined($pv) && !$pv_copy_on_grow) {
 	$init->add(savepvn(sprintf("xpviv_list[%d].xpv_pv",
 				   $xpvivsect->index), $pv));
     }
@@ -486,17 +618,14 @@ sub B::PVNV::save {
     my ($sv) = @_;
     my $sym = objsym($sv);
     return $sym if defined $sym;
-    my $pv = $sv->PV;     
-    $pv = '' unless defined $pv;
-    my $len = length($pv);
-    my ($pvsym, $pvmax) = savepv($pv);
+    my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
     my $val= $sv->NVX;
     $val .= '.00' if $val =~ /^-?\d+$/;
     $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
-			    $pvsym, $len, $pvmax, $sv->IVX, $val));
+			    $savesym, $len, $pvmax, $sv->IVX, $val));
     $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
 			 $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
-    if (!$pv_copy_on_grow) {
+    if (defined($pv) && !$pv_copy_on_grow) {
 	$init->add(savepvn(sprintf("xpvnv_list[%d].xpv_pv",
 				   $xpvnvsect->index), $pv));
     }
@@ -507,7 +636,7 @@ sub B::BM::save {
     my ($sv) = @_;
     my $sym = objsym($sv);
     return $sym if defined $sym;
-    my $pv = $sv->PV . "\0" . $sv->TABLE;
+    my $pv = pack "a*", ($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,
@@ -526,13 +655,11 @@ 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));
+    my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
+    $xpvsect->add(sprintf("%s, %u, %u", $savesym, $len, $pvmax));
     $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
 			 $xpvsect->index, $sv->REFCNT , $sv->FLAGS));
-    if (!$pv_copy_on_grow) {
+    if (defined($pv) && !$pv_copy_on_grow) {
 	$init->add(savepvn(sprintf("xpv_list[%d].xpv_pv",
 				   $xpvsect->index), $pv));
     }
@@ -543,16 +670,16 @@ 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);
+    my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
+
     $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
-			    $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
+                            $savesym, $len, $pvmax,
+                            $sv->IVX, $sv->NVX));
     $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
-			 $xpvmgsect->index, $sv->REFCNT , $sv->FLAGS));
-    if (!$pv_copy_on_grow) {
-	$init->add(savepvn(sprintf("xpvmg_list[%d].xpv_pv",
-				   $xpvmgsect->index), $pv));
+                         $xpvmgsect->index, $sv->REFCNT , $sv->FLAGS));
+    if (defined($pv) && !$pv_copy_on_grow) {
+        $init->add(savepvn(sprintf("xpvmg_list[%d].xpv_pv",
+                                   $xpvmgsect->index), $pv));
     }
     $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
     $sv->save_magic;
@@ -574,7 +701,6 @@ sub B::PVMG::save_magic {
     my ($mg, $type, $obj, $ptr,$len,$ptrsv);
     foreach $mg (@mgchain) {
 	$type = $mg->TYPE;
-	$obj = $mg->OBJ;
 	$ptr = $mg->PTR;
 	$len=$mg->LENGTH;
 	if ($debug_mg) {
@@ -582,13 +708,25 @@ sub B::PVMG::save_magic {
 			 class($sv), $$sv, class($obj), $$obj,
 			 cchar($type), cstring($ptr));
 	}
-	$obj->save;
+
+        unless( $type eq 'r' ) {
+          $obj = $mg->OBJ;
+          $obj->save;
+        }
+
 	if ($len == HEf_SVKEY){
 		#The pointer is an SV*
 		$ptrsv=svref_2object($ptr)->save;
 		$init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);",
 			   $$sv, $$obj, cchar($type),$ptrsv,$len));
-	}else{
+        }elsif( $type eq 'r' ){
+#               can't save r-MAGIC: we need a PMOP to recompile
+#               the regexp, so die 'cleanly'
+                confess "Can't save r-MAGICAL scalars (yet)"
+#               my($resym,$relen) = savere( $sv->precomp );
+#               $init->add(sprintf("sv_magic((SV*)s\\_%x, , %s, %s, %d);",
+#                                  $$sv, $resym, cchar($type),cstring($ptr),$len));
+        }else{
 		$init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
 			   $$sv, $$obj, cchar($type),cstring($ptr),$len));
 	}
@@ -599,9 +737,20 @@ sub B::RV::save {
     my ($sv) = @_;
     my $sym = objsym($sv);
     return $sym if defined $sym;
-    my $rv = $sv->RV->save;
-    $rv =~ s/^\([AGHS]V\s*\*\)\s*(\&sv_list.*)$/$1/;
-    $xrvsect->add($rv);
+    my $rv = save_rv( $sv );
+    # GVs need to be handled at runtime
+    if( ref( $sv->RV ) eq 'B::GV' ) {
+        $xrvsect->add( "(SV*)Nullgv" );
+        $init->add(sprintf("xrv_list[%d].xrv_rv = (SV*)%s;\n", $xrvsect->index, $rv));
+    }
+    # and stashes, too
+    elsif( $sv->RV->isa( 'B::HV' ) && $sv->RV->NAME ) {
+        $xrvsect->add( "(SV*)Nullhv" );
+        $init->add(sprintf("xrv_list[%d].xrv_rv = (SV*)%s;\n", $xrvsect->index, $rv));
+    }
+    else {
+        $xrvsect->add($rv);
+    }
     $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
 			 $xrvsect->index, $sv->REFCNT , $sv->FLAGS));
     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
@@ -645,21 +794,52 @@ sub B::CV::save {
     }
     my $root = $cv->ROOT;
     my $cvxsub = $cv->XSUB;
+    my $isconst = $cv->CvFLAGS & CVf_CONST;
+    if( $isconst ) {
+        my $value = $cv->XSUBANY;
+        my $stash = $gv->STASH;
+        my $vsym = $value->save;
+        my $stsym = $stash->save;
+        my $name = cstring($cvname);
+        $decl->add( "static CV* cv$cv_index;" );
+        $init->add( "cv$cv_index = newCONSTSUB( $stsym, NULL, $vsym );" );
+        my $sym = savesym( $cv, "cv$cv_index" );
+        $cv_index++;
+        return $sym;
+    }
     #INIT is removed from the symbol table, so this call must come
     # from PL_initav->save. Re-bootstrapping  will push INIT back in
     # so nullop should be sent.
-    if ($cvxsub && ($cvname ne "INIT")) {
+    if (!$isconst && $cvxsub && ($cvname ne "INIT")) {
 	my $egv = $gv->EGV;
 	my $stashname = $egv->STASH->NAME;
          if ($cvname eq "bootstrap")
-          {                                   
-           my $file = $gv->FILE;    
+          { 
+           my $file = $gv->FILE;
            $decl->add("/* bootstrap $file */"); 
            warn "Bootstrap $stashname $file\n";
-           $xsub{$stashname}='Dynamic'; 
+           # if it not isa('DynaLoader'), it should hopefully be XSLoaded
+           # ( attributes being an exception, of course )
+           if( $stashname ne 'attributes' &&
+               !UNIVERSAL::isa($stashname,'DynaLoader') ) {
+            $xsub{$stashname}='Dynamic-XSLoaded';
+            $use_xsloader = 1;
+           }
+           else {
+            $xsub{$stashname}='Dynamic';
+           }
 	   # $xsub{$stashname}='Static' unless  $xsub{$stashname};
            return qq/NULL/;
-          }                                   
+          }
+         else
+          {
+           # XSUBs for IO::File, IO::Handle, IO::Socket,
+           # IO::Seekable and IO::Poll
+           # are defined in IO.xs, so let's bootstrap it
+           svref_2object( \&IO::bootstrap )->save
+            if grep { $stashname eq $_ } qw(IO::File IO::Handle IO::Socket
+                                              IO::Seekable IO::Poll);
+          }
         warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv;
 	return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/;
     }
@@ -769,7 +949,8 @@ sub B::GV::save {
     }
     my $is_empty = $gv->is_empty;
     my $gvname = $gv->NAME;
-    my $name = cstring($gv->STASH->NAME . "::" . $gvname);
+    my $fullname = $gv->STASH->NAME . "::" . $gvname;
+    my $name = cstring($fullname);
     #warn "GV name is $name\n"; # debug
     my $egvsym;
     unless ($is_empty) {
@@ -796,33 +977,54 @@ sub B::GV::save {
     if ($gvrefcnt > 1) {
 	$init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
     }
+    # some non-alphavetic globs require some parts to be saved
+    # ( ex. %!, but not $! )
+    sub Save_HV() { 1 }
+    sub Save_AV() { 2 }
+    sub Save_SV() { 4 }
+    sub Save_CV() { 8 }
+    sub Save_FORM() { 16 }
+    sub Save_IO() { 32 }
+    my $savefields = 0;
+    if( $gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/ ) {
+        $savefields = Save_HV|Save_AV|Save_SV|Save_CV|Save_FORM|Save_IO;
+    }
+    elsif( $gvname eq '!' ) {
+        $savefields = Save_HV;
+    }
+    # attributes::bootstrap is created in perl_parse
+    # saving it would overwrite it, because perl_init() is
+    # called after perl_parse()
+    $savefields&=~Save_CV if $fullname eq 'attributes::bootstrap';
+
+    # save it
     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)$/) {
+    } elsif ($savefields) {
 	# Don't save subfields of special GVs (*_, *1, *# and so on)
 #	warn "GV::save saving subfields\n"; # debug
 	my $gvsv = $gv->SV;
-	if ($$gvsv) {
+	if ($$gvsv && $savefields&Save_SV) {
 	    $gvsv->save;
 	    $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
 #	    warn "GV::save \$$name\n"; # debug
 	}
 	my $gvav = $gv->AV;
-	if ($$gvav) {
+	if ($$gvav && $savefields&Save_AV) {
 	    $gvav->save;
 	    $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
 #	    warn "GV::save \@$name\n"; # debug
 	}
 	my $gvhv = $gv->HV;
-	if ($$gvhv) {
+	if ($$gvhv && $savefields&Save_HV) {
 	    $gvhv->save;
 	    $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
 #	    warn "GV::save \%$name\n"; # debug
 	}
 	my $gvcv = $gv->CV;
-	if ($$gvcv) { 
+	if ($$gvcv && $savefields&Save_CV) {
 	    my $origname=cstring($gvcv->GV->EGV->STASH->NAME .
 		 "::" . $gvcv->GV->EGV->NAME);  
 	    if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias
@@ -832,7 +1034,7 @@ sub B::GV::save {
                 $init->add("\tGvCV($sym)=cv;");
                 $init->add("\tSvREFCNT_inc((SV *)cv);");
                 $init->add("}");    
-	    } else {     
+	    } else {
                $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save));
 #              warn "GV::save &$name\n"; # debug
 	    } 
@@ -840,15 +1042,21 @@ sub B::GV::save {
 	$init->add(sprintf("GvFILE($sym) = %s;", cstring($gv->FILE)));
 #	warn "GV::save GvFILE(*$name)\n"; # debug
 	my $gvform = $gv->FORM;
-	if ($$gvform) {
+	if ($$gvform && $savefields&Save_FORM) {
 	    $gvform->save;
 	    $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
 #	    warn "GV::save GvFORM(*$name)\n"; # debug
 	}
 	my $gvio = $gv->IO;
-	if ($$gvio) {
+	if ($$gvio && $savefields&Save_IO) {
 	    $gvio->save;
 	    $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
+            if( $fullname =~ m/::DATA$/ && $save_data_fh ) {
+                no strict 'refs';
+                my $fh = *{$fullname}{IO};
+                use strict 'refs';
+                $gvio->save_data( $fullname, <$fh> ) if $fh->opened;
+            }
 #	    warn "GV::save GvIO(*$name)\n"; # debug
 	}
     }
@@ -940,7 +1148,8 @@ sub B::HV::save {
 	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)));
+			       cstring($key),length(pack "a*",$key),
+                               $value, hash($key)));
 #	    $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
 #			       cstring($key),length($key),$value, 0));
 	}
@@ -950,6 +1159,26 @@ sub B::HV::save {
     return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
 }
 
+sub B::IO::save_data {
+    my( $io, $globname, @data ) = @_;
+    my $data = join '', @data;
+
+    # XXX using $DATA might clobber it!
+    my $sym = svref_2object( \\$data )->save;
+    foreach my $i ( split /\n/, <<CODE ) {
+    {
+        GV* gv = (GV*)gv_fetchpv( "$globname", TRUE, SVt_PV );
+        SV* sv = $sym;
+        GvSV( gv ) = sv;
+    }
+CODE
+        $init->add( $i );
+    }
+    # for PerlIO::Scalar
+    $use_xsloader = 1;
+    $init->add_eval( sprintf 'open(%s, "<", $%s)', $globname, $globname );
+}
+
 sub B::IO::save {
     my ($io) = @_;
     my $sym = objsym($io);
@@ -966,6 +1195,16 @@ sub B::IO::save {
     $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
 			 $xpviosect->index, $io->REFCNT , $io->FLAGS));
     $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
+    # deal with $x = *STDIN/STDOUT/STDERR{IO}
+    my $perlio_func;
+    foreach ( qw(stdin stdout stderr) ) {
+        $io->IsSTD($_) and $perlio_func = $_;
+    }
+    if( $perlio_func ) {
+        $init->add( "IoIFP(${sym})=PerlIO_${perlio_func}();" );
+        $init->add( "IoOFP(${sym})=PerlIO_${perlio_func}();" );
+    }
+
     my ($field, $fsym);
     foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
       	$fsym = $io->$field();
@@ -1080,7 +1319,6 @@ typedef struct {
 
 #define UNUSED 0
 #define sym_0 0
-
 EOT
     print "static GV *gv_list[$gv_index];\n" if $gv_index;
     print "\n";
@@ -1096,6 +1334,8 @@ sub output_boilerplate {
 /* Workaround for mapstart: the only op which needs a different ppaddr */
 #undef Perl_pp_mapstart
 #define Perl_pp_mapstart Perl_pp_grepstart
+#undef OP_MAPSTART
+#define OP_MAPSTART OP_GREPSTART
 #define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
 
@@ -1105,6 +1345,52 @@ static PerlInterpreter *my_perl;
 EOT
 }
 
+sub init_op_addr {
+    my( $op_type, $num ) = @_;
+    my $op_list = $op_type."_list";
+
+    $init->add( split /\n/, <<EOT );
+    {
+        int i;
+
+        for( i = 0; i < ${num}; ++i )
+        {
+            ${op_list}\[i].op_ppaddr = PL_ppaddr[INT2PTR(int,${op_list}\[i].op_ppaddr)];
+        }
+    }
+EOT
+}
+
+sub init_op_warn {
+    my( $op_type, $num ) = @_;
+    my $op_list = $op_type."_list";
+
+    # for resons beyond imagination, MSVC5 considers pWARN_ALL non-const
+    $init->add( split /\n/, <<EOT );
+    {
+        int i;
+
+        for( i = 0; i < ${num}; ++i )
+        {
+            switch( (int)(${op_list}\[i].cop_warnings) )
+            {
+            case 1:
+                ${op_list}\[i].cop_warnings = pWARN_ALL;
+                break;
+            case 2:
+                ${op_list}\[i].cop_warnings = pWARN_NONE;
+                break;
+            case 3:
+                ${op_list}\[i].cop_warnings = pWARN_STD;
+                break;
+            default:
+                break;
+            }
+        }
+    }
+EOT
+}
+
 sub output_main {
     print <<'EOT';
 int
@@ -1113,6 +1399,8 @@ main(int argc, char **argv, char **env)
     int exitstatus;
     int i;
     char **fakeargv;
+    GV* tmpgv;
+    SV* tmpsv;
 
     PERL_SYS_INIT3(&argc,&argv,&env);
  
@@ -1130,28 +1418,63 @@ main(int argc, char **argv, char **env)
 #endif
 
 #ifdef ALLOW_PERL_OPTIONS
-#define EXTRA_OPTIONS 2
-#else
 #define EXTRA_OPTIONS 3
+#else
+#define EXTRA_OPTIONS 4
 #endif /* ALLOW_PERL_OPTIONS */
     New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
+
     fakeargv[0] = argv[0];
     fakeargv[1] = "-e";
     fakeargv[2] = "";
+EOT
+    # honour -T
+    print sprintf '    fakeargv[3] = ( %s ) ? "-T" : "" ;'."\n", ${^TAINT};
+    print <<'EOT';
 #ifndef ALLOW_PERL_OPTIONS
-    fakeargv[3] = "--";
+    fakeargv[4] = "--";
 #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]);
-    PL_main_cv = PL_compcv;
+    TAINT;
+EOT
+
+    if( $use_perl_script_name ) {
+        my $dollar_0 = $0;
+        $dollar_0 =~ s/\\/\\\\/g;
+        $dollar_0 = '"' . $dollar_0 . '"';
+
+        print <<EOT;
+    if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */
+        tmpsv = GvSV(tmpgv);
+        sv_setpv(tmpsv, ${dollar_0});
+        SvSETMAGIC(tmpsv);
+    }
+EOT
+    }
+
+    print <<'EOT';
+    if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
+        tmpsv = GvSV(tmpgv);
+#ifdef WIN32
+        sv_setpv(tmpsv,"perl.exe");
+#else
+        sv_setpv(tmpsv,"perl");
+#endif
+        SvSETMAGIC(tmpsv);
+    }
+
+    TAINT_NOT;
+
+    /* PL_main_cv = PL_compcv; */
     PL_compcv = 0;
 
     exitstatus = perl_init();
@@ -1184,7 +1507,7 @@ EOT
     delete $xsub{'UNIVERSAL'}; 
     print("/* bootstrapping code*/\n\tSAVETMPS;\n");
     print("\ttarg=sv_newmortal();\n");
-    print "#ifdef DYNALOADER_BOOTSTRAP\n";
+    print "#ifdef USE_DYNAMIC_LOADING\n";
     print "\tPUSHMARK(sp);\n";
     print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
     print qq/\tPUTBACK;\n/;
@@ -1192,7 +1515,7 @@ EOT
     print qq/\tSPAGAIN;\n/;
     print "#endif\n";
     foreach my $stashname (keys %xsub){
-	if ($xsub{$stashname} ne 'Dynamic') {
+	if ($xsub{$stashname} !~ m/Dynamic/ ) {
 	   my $stashxsub=$stashname;
 	   $stashxsub  =~ s/::/__/g; 
 	   print "\tPUSHMARK(sp);\n";
@@ -1217,15 +1540,20 @@ EOT
     print("\ttarg=sv_newmortal();\n");
     foreach my $stashname (@DynaLoader::dl_modules) {
 	warn "Loaded $stashname\n";
-	if (exists($xsub{$stashname}) && $xsub{$stashname} eq 'Dynamic') {
+	if (exists($xsub{$stashname}) && $xsub{$stashname} =~ m/Dynamic/) {
   	   my $stashxsub=$stashname;
 	   $stashxsub  =~ s/::/__/g; 
    	   print "\tPUSHMARK(sp);\n";
    	   print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
 	   print qq/\tPUTBACK;\n/;
-           print "#ifdef DYNALOADER_BOOTSTRAP\n";
+           print "#ifdef USE_DYNAMIC_LOADING\n";
 	   warn "bootstrapping $stashname added to xs_init\n";
-	   print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
+           if( $xsub{$stashname} eq 'Dynamic' ) {
+              print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
+           }
+           else {
+              print qq/\tperl_call_pv("XSLoader::load",G_DISCARD);\n/;
+           }
            print "\n#else\n";
 	   print "\tboot_$stashxsub(aTHX_ NULL);\n";
            print "#endif\n";
@@ -1264,6 +1592,8 @@ sub B::GV::savecv
  my $av = $gv->AV;
  my $hv = $gv->HV;
 
+ my $fullname = $gv->STASH->NAME . "::" . $gv->NAME;
+
  # We may be looking at this package just because it is a branch in the 
  # symbol table which is on the path to a package which we need to save
  # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
@@ -1411,17 +1741,59 @@ sub descend_marked_unused {
 }
  
 sub save_main {
+    # this is mainly for the test suite
+    my $warner = $SIG{__WARN__};
+    local $SIG{__WARN__} = sub { print STDERR @_ };
+
     warn "Starting compile\n";
     warn "Walking tree\n";
     seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
     walkoptree(main_root, "save");
     warn "done main optree, walking symtable for extras\n" if $debug_cv;
     save_unused_subs();
+    # XSLoader was used, force saving of XSLoader::load
+    if( $use_xsloader ) {
+        my $cv = svref_2object( \&XSLoader::load );
+        $cv->save;
+    }
+    # save %SIG ( in case it was set in a BEGIN block )
+    if( $save_sig ) {
+        local $SIG{__WARN__} = $warner;
+        $init->add("{", "\tHV* hv = get_hv(\"main::SIG\",1);" );
+        foreach my $k ( keys %SIG ) {
+            next unless $SIG{$k};
+            my $cv = svref_2object( \$SIG{$k} );
+            my $sv = $cv->save;
+            $init->add('{',sprintf 'SV* sv = (SV*)%s;', $sv );
+            $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
+                               cstring($k),length(pack "a*",$k),
+                               'sv', hash($k)));
+            $init->add('mg_set(sv);','}');
+        }
+        $init->add('}');
+    }
+    # honour -w
+    $init->add( sprintf "    PL_dowarn = ( %s ) ? G_WARN_ON : G_WARN_OFF;", $^W );
+    #
     my $init_av = init_av->save;
+    my $end_av = end_av->save;
     $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
 	       sprintf("PL_main_start = s\\_%x;", ${main_start()}),
-              "PL_initav = (AV *) $init_av;");                                
+              "PL_initav = (AV *) $init_av;",
+              "PL_endav = (AV*) $end_av;");
     save_context();
+    # init op addrs ( must be the last action, otherwise
+    # some ops might not be initialized
+    if( $optimize_ppaddr ) {
+        foreach my $i ( @op_sections ) {
+            my $section = $$i;
+            next unless $section->index >= 0;
+            init_op_addr( $section->name, $section->index + 1);
+        }
+    }
+    init_op_warn( $copsect->name, $copsect->index + 1)
+      if $optimize_warn_sv && $copsect->index >= 0;
+
     warn "Writing output\n";
     output_boilerplate();
     print "\n";
@@ -1431,7 +1803,7 @@ sub save_main {
 }
 
 sub init_sections {
-    my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
+    my @sections = (decl => \$decl, sym => \$symsect,
 		    binop => \$binopsect, condop => \$condopsect,
 		    cop => \$copsect, padop => \$padopsect,
 		    listop => \$listopsect, logop => \$logopsect,
@@ -1447,7 +1819,8 @@ sub init_sections {
     while (($name, $sectref) = splice(@sections, 0, 2)) {
 	$$sectref = new B::C::Section $name, \%symtable, 0;
     }
-}           
+    $init = new B::C::InitSection 'init', \%symtable, 0;
+}
 
 sub mark_unused
 {
@@ -1458,6 +1831,14 @@ sub mark_unused
 sub compile {
     my @options = @_;
     my ($option, $opt, $arg);
+    my @eval_at_startup;
+    my %option_map = ( 'cog' => \$pv_copy_on_grow,
+                       'save-data' => \$save_data_fh,
+                       'ppaddr' => \$optimize_ppaddr,
+                       'warn-sv' => \$optimize_warn_sv,
+                       'use-script-name' => \$use_perl_script_name,
+                       'save-sig-hash' => \$save_sig,
+                     );
   OPTION:
     while ($option = shift @options) {
 	if ($option =~ /^-(.)(.*)/) {
@@ -1500,11 +1881,14 @@ sub compile {
 	    mark_unused($arg,undef);
 	} 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;
-	    }
+            $arg =~ m/(no-)?(.*)/;
+            my $no = defined($1) && $1 eq 'no-';
+            $arg = $no ? $2 : $arg;
+            if( exists $option_map{$arg} ) {
+                ${$option_map{$arg}} = !$no;
+            } else {
+                die "Invalid optimization '$arg'";
+            }
 	} elsif ($opt eq "O") {
 	    $arg = 1 if $arg eq "";
 	    $pv_copy_on_grow = 0;
@@ -1512,11 +1896,16 @@ sub compile {
 		# Optimisations for -O1
 		$pv_copy_on_grow = 1;
 	    }
+        } elsif ($opt eq "e") {
+            push @eval_at_startup, $arg;
 	} elsif ($opt eq "l") {
 	    $max_string_len = $arg;
 	}
     }
     init_sections();
+    foreach my $i ( @eval_at_startup ) {
+        $init->add_eval( $i );
+    }
     if (@options) {
 	return sub {
 	    my $objname;
@@ -1614,15 +2003,37 @@ prints MAGIC information on saving
 
 =item B<-f>
 
-Force optimisations on or off one at a time.
+Force options/optimisations on or off one at a time. You can explicitly
+disable an option using B<-fno-option>. All options default to
+B<disabled>.
+
+=over 4
 
 =item B<-fcog>
 
 Copy-on-grow: PVs declared and initialised statically.
 
-=item B<-fno-cog>
+=item B<-fsave-data>
+
+Save package::DATA filehandles ( only available with PerlIO ).
 
-No copy-on-grow.
+=item B<-fppaddr>
+
+Optimize the initialization of op_ppaddr.
+
+=item B<-fwarn-sv>
+
+Optimize the initialization of cop_warnings.
+
+=item B<-fuse-script-name>
+
+Use the script name instead of the program name as $0.
+
+=item B<-fsave-sig-hash>
+
+Save compile-time modifications to the %SIG hash.
+
+=back
 
 =item B<-On>
 
diff --git a/ext/B/defsubs_h.PL b/ext/B/defsubs_h.PL
index df64ab3a2e..37bfeb7e9d 100644
--- a/ext/B/defsubs_h.PL
+++ b/ext/B/defsubs_h.PL
@@ -12,7 +12,7 @@ foreach my $const (qw(
 		      SVf_READONLY SVTYPEMASK
 		      GVf_IMPORTED_AV GVf_IMPORTED_HV
 		      GVf_IMPORTED_SV GVf_IMPORTED_CV
-		      CVf_METHOD CVf_LOCKED CVf_LVALUE
+		      CVf_METHOD CVf_LOCKED CVf_LVALUE CVf_CONST
                       SVpad_OUR SVf_IOK SVf_IVisUV SVf_NOK SVf_POK 
 		      SVf_ROK SVp_IOK SVp_POK SVp_NOK
 		      ))
diff --git a/t/TEST b/t/TEST
index 278097a53c..54ed3efee6 100755
--- a/t/TEST
+++ b/t/TEST
@@ -10,9 +10,10 @@ $| = 1;
 $ENV{PERL_CORE} = 1;
 
 # Cheesy version of Getopt::Std.  Maybe we should replace it with that.
+@argv = ();
 if ($#ARGV >= 0) {
     foreach my $idx (0..$#ARGV) {
-	next unless $ARGV[$idx] =~ /^-(\S+)$/;
+	push( @argv, $ARGV[$idx] ), next unless $ARGV[$idx] =~ /^-(\S+)$/;
 	$core    = 1 if $1 eq 'core';
 	$verbose = 1 if $1 eq 'v';
 	$with_utf= 1 if $1 eq 'utf8';
@@ -22,9 +23,9 @@ if ($#ARGV >= 0) {
 	    $deparse = 1;
 	    $deparse_opts = $1;
 	}
-	splice(@ARGV, $idx, 1);
     }
 }
+@ARGV = @argv;
 
 chdir 't' if -f 't/TEST';
 
@@ -181,6 +182,7 @@ EOT
  	    $switch = '';
  	}
 
+        my $test_executable; # for 'compile' tests
 	my $file_opts = "";
 	if ($type eq 'deparse') {
 	    # Look for #line directives which change the filename
@@ -208,17 +210,38 @@ EOT
 	    open(RESULTS,$run) or print "can't run '$run': $!.\n";
 	}
 	else {
-	    my $compile =
-		"./perl $testswitch -I../lib ../utils/perlcc -I .. $args -o ".
-                "$test.plc $utf $test ".
-		" && $test.plc |";
+	    my $compile;
+            my $pl2c = "$testswitch -I../lib ../utils/perlcc --testsuite " .
+                       "$switch -L .. " .
+                       "-I \".. ../lib/CORE\" $args $utf $test -o ";
+
+            if( $^O eq 'MSWin32' ) {
+                $test_executable = "$test.exe";
+                # hopefully unused name...
+                open HACK, "> xweghyz.pl";
+                print HACK <<EOT;
+#!./perl
+
+open HACK, '.\\perl $pl2c $test_executable |';
+# cl.exe prints the name of the .c file on stdout (\%^\$^#)
+while(<HACK>) {m/^\w+\.[cC]\$/ && next;print}
+open HACK, '$test_executable |';
+while(<HACK>) {print}
+EOT
+                close HACK;
+                $compile = 'xweghyz.pl |';
+            }
+            else {
+                $test_executable = "$test.plc";
+                $compile = "./perl $pl2c $test_executable && $test_executable |";
+            }
+            unlink $test_executable if -f $test_executable;
 	    open(RESULTS, $compile)
 		or print "can't compile '$compile': $!.\n";
-	    unlink "$test.plc";
 	}
 
-	$ok = 0;
-	$next = 0;
+        $ok = 0;
+        $next = 0;
 	while (<RESULTS>) {
 	    if ($verbose) {
 		print $_;
@@ -271,7 +294,12 @@ EOT
 		die "rename: perl3.log to perl.3log.$tpp: $!\n";
 	}
 	$next = $next - 1;
-	if ($ok && $next == $max) {
+        # test if the compiler compiled something
+        if( $type eq 'compile' && !-e "$test_executable" ) {
+            $ok = 0;
+            print "Test did not compile\n";
+        }
+	if ($ok && $next == $max ) {
 	    if ($max) {
 		print "ok\n";
 		$good = $good + 1;
diff --git a/utils/perlcc.PL b/utils/perlcc.PL
index df27b75dc4..51f52eda5a 100644
--- a/utils/perlcc.PL
+++ b/utils/perlcc.PL
@@ -63,11 +63,14 @@ use subs qw{
     grab_stash parse_argv sanity_check vprint yclept spawnit
 };
 sub opt(*); # imal quoting
+sub is_win32();
+sub is_msvc();
 
 our ($Options, $BinPerl, $Backend);
 our ($Input => $Output);
 our ($logfh);
 our ($cfile);
+our (@begin_output); # output from BEGIN {}, for testsuite
 
 # eval { main(); 1 } or die;
 
@@ -161,7 +164,7 @@ sub parse_argv {
         'L:s',          # lib directory
         'I:s',          # include directories (FOR C, NOT FOR PERL)
         'o:s',          # Output executable
-        'v:i',           # Verbosity level
+        'v:i',          # Verbosity level
         'e:s',          # One-liner
 	'r',            # run resulting executable
         'B',            # Byte compiler backend
@@ -170,24 +173,34 @@ sub parse_argv {
         'h',            # Help me
         'S',            # Dump C files
 	'r',            # run the resulting executable
+        'T',            # run the backend using perl -T
+        't',            # run the backend using perl -t
         'static',       # Dirty hack to enable -shared/-static
         'shared',       # Create a shared library (--shared for compat.)
-	'log:s'         # where to log compilation process information
+	'log:s',        # where to log compilation process information
+        'testsuite',    # try to be nice to testsuite
     );
-        
+
     $Options->{v} += 0;
 
+    if( opt(t) && opt(T) ) {
+        warn "Can't specify both -T and -t, -t ignored";
+        $Options->{t} = 0;
+    }
+
     helpme() if opt(h); # And exit
 
-    $Output = opt(o) || 'a.out';
-    $Output = relativize($Output);
+    $Output = opt(o) || ( is_win32 ? 'a.exe' : 'a.out' );
+    $Output = is_win32() ? $Output : relativize($Output);
     $logfh  = new FileHandle(">> " . opt('log')) if (opt('log'));
 
     if (opt(e)) {
         warn "$0: using -e 'code' as input file, ignoring @ARGV\n" if @ARGV;
         # We don't use a temporary file here; why bother?
         # XXX: this is not bullet proof -- spaces or quotes in name!
-        $Input = "-e '".opt(e)."'"; # Quotes eaten by shell
+        $Input = is_win32() ? # Quotes eaten by shell
+            '-e "'.opt(e).'"' :
+            "-e '".opt(e)."'";
     } else {
         $Input = shift @ARGV;  # XXX: more files?
         _usage_and_die("$0: No input file specified\n") unless $Input;
@@ -252,7 +265,7 @@ EOF
 	my @error = grep { !/^$Input syntax OK$/o } @$error_r;
 	warn "$0: Unexpected compiler output:\n@error" if @error;
     }
-	
+
     # Write it and leave.
     print OUT @$output_r               or _die("can't write $Output: $!");
     close OUT                          or _die("can't close $Output: $!");
@@ -264,11 +277,25 @@ EOF
 
 sub compile_cstyle {
     my $stash = grab_stash();
-    
+    my $taint = opt(T) ? '-T' :
+                opt(t) ? '-t' : '';
+
     # What are we going to call our output C file?
     my $lose = 0;
     my ($cfh);
-
+    my $testsuite = '';
+
+    if (opt(testsuite)) {
+        my $bo = join '', @begin_output;
+        $bo =~ s/\\/\\\\\\\\/gs;
+        $bo =~ s/\n/\\n/gs;
+        $bo =~ s/,/\\054/gs;
+        # don't look at that: it hurts
+        $testsuite = q{-fuse-script-name,-fsave-data,-fsave-sig-hash,}.
+            qq[-e"print q{$bo}",] .
+            q{-e"open(Test::Builder::TESTOUT\054 '>&STDOUT') or die $!",} .
+            q{-e"open(Test::Builder::TESTERR\054 '>&STDERR') or die $!",};
+    }
     if (opt(S) || opt(c)) {
         # We need to keep it.
         if (opt(e)) {
@@ -297,7 +324,7 @@ sub compile_cstyle {
 
     # This has to do the write itself, so we can't keep a lock. Life
     # sucks.
-    my $command = "$BinPerl -MO=$Backend,$max_line_len$stash,-o$cfile $Input";
+    my $command = "$BinPerl $taint -MO=$Backend,$testsuite$max_line_len$stash,-o$cfile $Input";
     vprint 1, "Compiling...";
     vprint 1, "Calling $command";
 
@@ -309,7 +336,9 @@ sub compile_cstyle {
         _die("$0: $Input did not compile, which can't happen:\n@error\n");
     }
 
-    cc_harness($cfile,$stash) unless opt(c);
+    is_msvc ?
+        cc_harness_msvc($cfile,$stash) :
+        cc_harness($cfile,$stash) unless opt(c);
 
     if ($lose) {
         vprint 2, "unlinking $cfile";
@@ -317,6 +346,23 @@ sub compile_cstyle {
     }
 }
 
+sub cc_harness_msvc {
+    my ($cfile,$stash)=@_;
+    use ExtUtils::Embed ();
+    my $obj = "${Output}.obj";
+    my $compile = ExtUtils::Embed::ccopts." -c -Fo$obj $cfile ";
+    my $link = "-out:$Output $obj";
+    $compile .= " -I".$_ for split /\s+/, opt(I);
+    $link .= " -libpath:".$_ for split /\s+/, opt(L);
+    my @mods = split /-?u /, $stash;
+    $link .= " ".ExtUtils::Embed::ldopts("-std", \@mods);
+    $link .= " perl57.lib msvcrt.lib";
+    vprint 3, "running $Config{cc} $compile";
+    system("$Config{cc} $compile");
+    vprint 3, "running $Config{ld} $link";
+    system("$Config{ld} $link");
+}
+
 sub cc_harness {
 	my ($cfile,$stash)=@_;
 	use ExtUtils::Embed ();
@@ -356,7 +402,9 @@ sub yclept {
 
         warn "already called get_stash once" if $_stash;
 
-        my $command = "$BinPerl -MB::Stash -c $Input";
+        my $taint = opt(T) ? '-T' :
+                    opt(t) ? '-t' : '';
+        my $command = "$BinPerl $taint -MB::Stash -c $Input";
         # Filename here is perfectly sanitised.
         vprint 3, "Calling $command\n";
 
@@ -368,7 +416,14 @@ sub yclept {
             _die("$0: $Input did not compile:\n@error\n");
         }
 
+        # band-aid for modules with noisy BEGIN {}
+        foreach my $i ( @stash ) {
+            $i =~ m/-u(?:[\w:]+|\<none\>)$/ and $stash[0] = $i and next;
+            push @begin_output, $i;
+        }
+        chomp $stash[0];
         $stash[0] =~ s/,-u\<none\>//;
+        $stash[0] =~ s/^.*?-u/-u/s;
         vprint 2, "Stash: ", join " ", split /,?-u/, $stash[0];
         chomp $stash[0];
         return $_stash = $stash[0];
@@ -548,6 +603,9 @@ sub interruptrun
     return($text);
 }
 
+sub is_win32() { $^O =~ m/^MSWin/ }
+sub is_msvc() { is_win32 && $Config{cc} =~ m/^cl/i }
+
 END {
     unlink $cfile if ($cfile && !opt(S) && !opt(c));
 }