X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FB%2FB%2FCC.pm;h=98c931805583cd875babaf96a9cdb3c374d2710b;hb=1a67a97c0300941ac67bfb1dd421467b8c59e21c;hp=0f4cfd2858f407ee90dd85a3a4b6663e83e5f48b;hpb=a0d31f98675add34bdf823c365f4199ae3031cef;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/ext/B/B/CC.pm b/ext/B/B/CC.pm
index 0f4cfd2..98c9318 100644
--- a/ext/B/B/CC.pm
+++ b/ext/B/B/CC.pm
@@ -1,6 +1,6 @@
 #      CC.pm
 #
-#      Copyright (c) 1996, 1997 Malcolm Beattie
+#      Copyright (c) 1996, 1997, 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.
@@ -8,34 +8,19 @@
 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
+	timing_info init_av sv_undef amagic_generation 
+	OPf_WANT_LIST OPf_WANT OPf_MOD OPf_STACKED OPf_SPECIAL
+	OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV
+	OPpDEREF OPpFLIP_LINENUM G_ARRAY G_SCALAR    
+	CXt_NULL CXt_SUB CXt_EVAL CXt_LOOP CXt_SUBST CXt_BLOCK
+	);
+use B::C qw(save_unused_subs objsym init_sections mark_unused
 	    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
@@ -66,6 +51,7 @@ 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
+my %need_curcop;	# Hash of ops which need PL_curcop
 
 BEGIN {
     foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) {
@@ -73,11 +59,6 @@ BEGIN {
     }
 }
 
-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);
@@ -111,6 +92,10 @@ sub init_hash { map { $_ => 1 } @_ }
 #
 %skip_lexicals = init_hash qw(pp_enter pp_enterloop);
 %skip_invalidate = init_hash qw(pp_enter pp_enterloop);
+%need_curcop = init_hash qw(pp_rv2gv  pp_bless pp_repeat pp_sort pp_caller
+			pp_reset pp_rv2cv pp_entereval pp_require pp_dofile
+			pp_entertry pp_enterloop pp_enteriter pp_entersub
+			pp_enter);
 
 sub debug {
     if ($debug_runtime) {
@@ -167,7 +152,7 @@ sub init_pp {
     declare("SV", "**svp");
     map { declare("SV", "*$_") } qw(sv src dst left right);
     declare("MAGIC", "*mg");
-    $decl->add("static OP * $ppname _((ARGSproto));");
+    $decl->add("static OP * $ppname (pTHX);");
     debug "init_pp: $ppname\n" if $debug_queue;
 }
 
@@ -200,7 +185,7 @@ 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 top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" }
 
 sub pop_int { @stack ? (pop @stack)->as_int : "POPi" }
 sub pop_double { @stack ? (pop @stack)->as_double : "POPn" }
@@ -208,7 +193,7 @@ 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);
+	return ((pop @stack)->as_bool);
     } else {
 	# Careful: POPs has an auto-decrement and SvTRUE evaluates
 	# its argument more than once.
@@ -332,7 +317,7 @@ sub reload_lexicals {
 }
 my $curcop = new B::Shadow (sub {
     my $opsym = shift->save;
-    runtime("curcop = (COP*)$opsym;");
+    runtime("PL_curcop = (COP*)$opsym;");
 });
 
 #
@@ -350,8 +335,9 @@ sub dopoptoloop {
 sub dopoptolabel {
     my $label = shift;
     my $cxix = $#cxstack;
-    while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP
-	   && $cxstack[$cxix]->{label} ne $label) {
+    while ($cxix >= 0 &&
+	   ($cxstack[$cxix]->{type} != CXt_LOOP ||
+	    $cxstack[$cxix]->{label} ne $label)) {
 	$cxix--;
     }
     debug "dopoptolabel: returning $cxix" if $debug_cxstack;
@@ -399,7 +385,7 @@ sub load_pad {
 	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
+	    # temporaries have &PL_sv_undef instead of a PVNV for a name
 	    $flags = VALID_SV|TEMPORARY|REGISTER;
 	} else {
 	    if ($namesv->PV =~ /^\$(.*)_([di])(r?)$/) {
@@ -416,12 +402,22 @@ sub load_pad {
 	}
 	$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;
+
+	debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad;
     }
 }
 
+sub declare_pad {
+    my $ix;
+    for ($ix = 1; $ix <= $#pad; $ix++) {
+	my $type = $pad[$ix]->{type};
+	declare("IV", $type == T_INT ? 
+		sprintf("%s=0",$pad[$ix]->{iv}):$pad[$ix]->{iv}) if $pad[$ix]->save_int;
+	declare("double", $type == T_DOUBLE ?
+		 sprintf("%s = 0",$pad[$ix]->{nv}):$pad[$ix]->{nv} )if $pad[$ix]->save_double;
+
+    }
+}
 #
 # Debugging stuff
 #
@@ -445,7 +441,7 @@ sub write_label {
 sub loadop {
     my $op = shift;
     my $opsym = $op->save;
-    runtime("op = $opsym;") unless $know_op;
+    runtime("PL_op = $opsym;") unless $know_op;
     return $opsym;
 }
 
@@ -461,7 +457,7 @@ sub doop {
 sub gimme {
     my $op = shift;
     my $flags = $op->flags;
-    return (($flags & OPf_KNOW) ? ($flags & OPf_LIST) : "dowantarray()");
+    return (($flags & OPf_WANT) ? (($flags & OPf_WANT)== OPf_WANT_LIST? G_ARRAY:G_SCALAR) : "dowantarray()");
 }
 
 #
@@ -476,10 +472,12 @@ sub pp_null {
 sub pp_stub {
     my $op = shift;
     my $gimme = gimme($op);
-    if ($gimme != 1) {
+    if ($gimme != G_ARRAY) {
+	my $obj= new B::Stackobj::Const(sv_undef);
+    	push(@stack, $obj);
 	# XXX Change to push a constant sv_undef Stackobj onto @stack
-	write_back_stack();
-	runtime("if ($gimme != G_ARRAY) XPUSHs(&sv_undef);");
+	#write_back_stack();
+	#runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
     }
     return $op->next;
 }
@@ -499,7 +497,7 @@ sub pp_and {
     if (@stack >= 1) {
 	my $bool = pop_bool();
 	write_back_stack();
-	runtime(sprintf("if (!$bool) goto %s;", label($next)));
+	runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next)));
     } else {
 	runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)),
 		"*sp--;");
@@ -513,10 +511,10 @@ sub pp_or {
     reload_lexicals();
     unshift(@bblock_todo, $next);
     if (@stack >= 1) {
-	my $obj = pop @stack;
+	my $bool = pop_bool @stack;
 	write_back_stack();
-	runtime(sprintf("if (%s) { XPUSHs(%s); goto %s; }",
-			$obj->as_numeric, $obj->as_sv, label($next)));
+	runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }",
+			$bool, label($next)));
     } else {
 	runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
 		"*sp--;");
@@ -526,13 +524,13 @@ sub pp_or {
 	    
 sub pp_cond_expr {
     my $op = shift;
-    my $false = $op->false;
+    my $false = $op->next;
     unshift(@bblock_todo, $false);
     reload_lexicals();
     my $bool = pop_bool();
     write_back_stack();
     runtime(sprintf("if (!$bool) goto %s;", label($false)));
-    return $op->true;
+    return $op->other;
 }
 
 sub pp_padsv {
@@ -542,9 +540,9 @@ sub pp_padsv {
     if ($op->flags & OPf_MOD) {
 	my $private = $op->private;
 	if ($private & OPpLVAL_INTRO) {
-	    runtime("SAVECLEARSV(curpad[$ix]);");
+	    runtime("SAVECLEARSV(PL_curpad[$ix]);");
 	} elsif ($private & OPpDEREF) {
-	    runtime(sprintf("vivify_ref(curpad[%d], %d);",
+	    runtime(sprintf("vivify_ref(PL_curpad[%d], %d);",
 			    $ix, $private & OPpDEREF));
 	    $pad[$ix]->invalidate;
 	}
@@ -569,7 +567,7 @@ sub pp_nextstate {
     @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;");
+    runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;");
     if ($freetmps_each_bblock || $freetmps_each_loop) {
 	$need_freetmps = 1;
     } else {
@@ -584,15 +582,48 @@ sub pp_dbstate {
     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(@_) }
+#default_pp will handle this:
+#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_caller { $curcop->write_back; default_pp(@_) }
+#sub pp_reset { $curcop->write_back; default_pp(@_) }
 
+sub pp_rv2gv{
+    my $op =shift;
+    $curcop->write_back;
+    write_back_lexicals() unless $skip_lexicals{$ppname};
+    write_back_stack() unless $skip_stack{$ppname};
+    my $sym=doop($op);
+    if ($op->private & OPpDEREF) {
+        $init->add(sprintf("((UNOP *)$sym)->op_first = $sym;"));	
+        $init->add(sprintf("((UNOP *)$sym)->op_type = %d;", 
+		$op->first->type));	
+    }
+    return $op->next;
+}
+sub pp_sort {
+    my $op = shift;
+    my $ppname = $op->ppaddr;
+    if ( $op->flags & OPf_SPECIAL && $op->flags  & OPf_STACKED){   
+        #this indicates the sort BLOCK Array case
+        #ugly surgery required.
+        my $root=$op->first->sibling->first;
+        my $start=$root->first;
+	$op->first->save;
+	$op->first->sibling->save;
+	$root->save;
+	my $sym=$start->save;
+        my $fakeop=cc_queue("pp_sort".$$op,$root,$start);
+	$init->add(sprintf("(%s)->op_next=%s;",$sym,$fakeop));
+    }
+    $curcop->write_back;
+    write_back_lexicals();
+    write_back_stack();
+    doop($op);
+    return $op->next;
+}              
 sub pp_gv {
     my $op = shift;
     my $gvsym = $op->gv->save;
@@ -620,7 +651,7 @@ sub pp_aelemfast {
     my $flag = $op->flags & OPf_MOD;
     write_back_stack();
     runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);",
-	    "PUSHs(svp ? *svp : &sv_undef);");
+	    "PUSHs(svp ? *svp : &PL_sv_undef);");
     return $op->next;
 }
 
@@ -666,11 +697,15 @@ sub numeric_binop {
 	    }
 	} else {
 	    if ($force_int) {
+	        my $rightruntime = new B::Pseudoreg ("IV", "riv");
+	    	runtime(sprintf("$$rightruntime = %s;",$right));
 		runtime(sprintf("sv_setiv(TOPs, %s);",
-				&$operator("TOPi", $right)));
+				&$operator("TOPi", $$rightruntime)));
 	    } else {
+	    	my $rightruntime = new B::Pseudoreg ("double", "rnv");
+	    	runtime(sprintf("$$rightruntime = %s;",$right));
 		runtime(sprintf("sv_setnv(TOPs, %s);",
-				&$operator("TOPn", $right)));
+				&$operator("TOPn",$$rightruntime)));
 	    }
 	}
     } else {
@@ -694,6 +729,60 @@ sub numeric_binop {
     return $op->next;
 }
 
+sub pp_ncmp {
+    my ($op) = @_;
+    if ($op->flags & OPf_STACKED) {
+	my $right = pop_numeric();
+	if (@stack >= 1) {
+	    my $left = top_numeric();
+	    runtime sprintf("if (%s > %s){",$left,$right);
+		$stack[-1]->set_int(1);
+	    $stack[-1]->write_back();
+	    runtime sprintf("}else if (%s < %s ) {",$left,$right);
+		$stack[-1]->set_int(-1);
+	    $stack[-1]->write_back();
+	    runtime sprintf("}else if (%s == %s) {",$left,$right);
+		$stack[-1]->set_int(0);
+	    $stack[-1]->write_back();
+	    runtime sprintf("}else {"); 
+		$stack[-1]->set_sv("&PL_sv_undef");
+	    runtime "}";
+	} else {
+	    my $rightruntime = new B::Pseudoreg ("double", "rnv");
+	    runtime(sprintf("$$rightruntime = %s;",$right));
+	    runtime sprintf(qq/if ("TOPn" > %s){/,$rightruntime);
+	    runtime sprintf("sv_setiv(TOPs,1);");
+	    runtime sprintf(qq/}else if ( "TOPn" < %s ) {/,$$rightruntime);
+	    runtime sprintf("sv_setiv(TOPs,-1);");
+	    runtime sprintf(qq/} else if ("TOPn" == %s) {/,$$rightruntime);
+	    runtime sprintf("sv_setiv(TOPs,0);");
+	    runtime sprintf(qq/}else {/); 
+	    runtime sprintf("sv_setiv(TOPs,&PL_sv_undef;");
+	    runtime "}";
+	}
+    } else {
+       	my $targ = $pad[$op->targ];
+	 my $right = new B::Pseudoreg ("double", "rnv");
+	 my $left = new B::Pseudoreg ("double", "lnv");
+	 runtime(sprintf("$$right = %s; $$left = %s;",
+			    pop_numeric(), pop_numeric));
+	runtime sprintf("if (%s > %s){",$$left,$$right);
+		$targ->set_int(1);
+		$targ->write_back();
+	runtime sprintf("}else if (%s < %s ) {",$$left,$$right);
+		$targ->set_int(-1);
+		$targ->write_back();
+	runtime sprintf("}else if (%s == %s) {",$$left,$$right);
+		$targ->set_int(0);
+		$targ->write_back();
+	runtime sprintf("}else {"); 
+		$targ->set_sv("&PL_sv_undef");
+	runtime "}";
+	push(@stack, $targ);
+    }
+    return $op->next;
+}
+
 sub sv_binop {
     my ($op, $operator, $flags) = @_;
     if ($op->flags & OPf_STACKED) {
@@ -789,7 +878,6 @@ BEGIN {
     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");
@@ -808,12 +896,11 @@ BEGIN {
     # 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_add { numeric_binop($_[0], $plus_op) }
+    sub pp_subtract { numeric_binop($_[0], $minus_op) }
+    sub pp_multiply { numeric_binop($_[0], $multiply_op) }
     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) }
@@ -857,7 +944,7 @@ sub pp_sassign {
 	($src, $dst) = ($dst, $src) if $backwards;
 	my $type = $src->{type};
 	if ($type == T_INT) {
-	    $dst->set_int($src->as_int);
+	    $dst->set_int($src->as_int,$src->{flags} & VALID_UNSIGNED);
 	} elsif ($type == T_DOUBLE) {
 	    $dst->set_numeric($src->as_numeric);
 	} else {
@@ -868,9 +955,13 @@ sub pp_sassign {
 	if ($backwards) {
 	    my $src = pop @stack;
 	    my $type = $src->{type};
-	    runtime("if (tainting && tainted) TAINT_NOT;");
+	    runtime("if (PL_tainting && PL_tainted) TAINT_NOT;");
 	    if ($type == T_INT) {
-		runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int);
+                if ($src->{flags} & VALID_UNSIGNED){ 
+                     runtime sprintf("sv_setuv(TOPs, %s);", $src->as_int);
+                }else{
+                    runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int);
+                }
 	    } elsif ($type == T_DOUBLE) {
 		runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double);
 	    } else {
@@ -878,7 +969,7 @@ sub pp_sassign {
 	    }
 	    runtime("SvSETMAGIC(TOPs);");
 	} else {
-	    my $dst = pop @stack;
+	    my $dst = $stack[-1];
 	    my $type = $dst->{type};
 	    runtime("sv = POPs;");
 	    runtime("MAYBE_TAINT_SASSIGN_SRC(sv);");
@@ -887,7 +978,7 @@ sub pp_sassign {
 	    } elsif ($type == T_DOUBLE) {
 		$dst->set_double("SvNV(sv)");
 	    } else {
-		runtime("SvSetSV($dst->{sv}, sv);");
+		runtime("SvSetMagicSV($dst->{sv}, sv);");
 		$dst->invalidate;
 	    }
 	}
@@ -933,7 +1024,7 @@ sub pp_list {
     my $op = shift;
     write_back_stack();
     my $gimme = gimme($op);
-    if ($gimme == 1) { # sic
+    if ($gimme == G_ARRAY) { # sic
 	runtime("POPMARK;"); # need this even though not a "full" pp_list
     } else {
 	runtime("PP_LIST($gimme);");
@@ -943,21 +1034,56 @@ sub pp_list {
 
 sub pp_entersub {
     my $op = shift;
+    $curcop->write_back;
     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;");
+    runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
+    runtime("PL_op = (*PL_op->op_ppaddr)(aTHX);");
+    runtime("SPAGAIN;}");
     $know_op = 0;
     invalidate_lexicals(REGISTER|TEMPORARY);
     return $op->next;
 }
+sub pp_formline {
+    my $op = shift;
+    my $ppname = $op->ppaddr;
+    write_back_lexicals() unless $skip_lexicals{$ppname};
+    write_back_stack() unless $skip_stack{$ppname};
+    my $sym=doop($op);
+    # See comment in pp_grepwhile to see why!
+    $init->add("((LISTOP*)$sym)->op_first = $sym;");    
+    runtime("if (PL_op == ((LISTOP*)($sym))->op_first){");
+    runtime( sprintf("goto %s;",label($op->first)));
+    runtime("}");
+    return $op->next;
+}
 
+sub pp_goto{
+
+    my $op = shift;
+    my $ppname = $op->ppaddr;
+    write_back_lexicals() unless $skip_lexicals{$ppname};
+    write_back_stack() unless $skip_stack{$ppname};
+    my $sym=doop($op);
+    runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}");
+    invalidate_lexicals() unless $skip_invalidate{$ppname};
+    return $op->next;
+}
 sub pp_enterwrite {
     my $op = shift;
     pp_entersub($op);
 }
-
+sub pp_leavesub{
+    my $op = shift;
+    write_back_lexicals() unless $skip_lexicals{$ppname};
+    write_back_stack() unless $skip_stack{$ppname};
+    runtime("if (PL_curstackinfo->si_type == PERLSI_SORT){");   
+    runtime("\tPUTBACK;return 0;");
+    runtime("}");
+    doop($op);
+    return $op->next;
+}
 sub pp_leavewrite {
     my $op = shift;
     write_back_lexicals(REGISTER|TEMPORARY);
@@ -965,7 +1091,7 @@ sub pp_leavewrite {
     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("if (PL_op) PL_op = (*PL_op->op_ppaddr)(aTHX);");
     runtime("SPAGAIN;");
     $know_op = 0;
     invalidate_lexicals(REGISTER|TEMPORARY);
@@ -979,6 +1105,7 @@ sub doeval {
     write_back_stack();
     my $sym = loadop($op);
     my $ppaddr = $op->ppaddr;
+    #runtime(qq/printf("$ppaddr type eval\n");/);
     runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
     $know_op = 1;
     invalidate_lexicals(REGISTER|TEMPORARY);
@@ -986,9 +1113,24 @@ sub doeval {
 }
 
 sub pp_entereval { doeval(@_) }
-sub pp_require { doeval(@_) }
 sub pp_dofile { doeval(@_) }
 
+#pp_require is protected by pp_entertry, so no protection for it.
+sub pp_require {
+    my $op = shift;
+    $curcop->write_back;
+    write_back_lexicals(REGISTER|TEMPORARY);
+    write_back_stack();
+    my $sym = doop($op);
+    runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
+    runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);");
+    runtime("SPAGAIN;}");
+    $know_op = 1;
+    invalidate_lexicals(REGISTER|TEMPORARY);
+    return $op->next;
+}
+
+
 sub pp_entertry {
     my $op = shift;
     $curcop->write_back;
@@ -996,12 +1138,19 @@ sub pp_entertry {
     write_back_stack();
     my $sym = doop($op);
     my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++);
-    declare("Sigjmp_buf", $jmpbuf);
+    declare("JMPENV", $jmpbuf);
     runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
     invalidate_lexicals(REGISTER|TEMPORARY);
     return $op->next;
 }
 
+sub pp_leavetry{
+	my $op=shift;
+	default_pp($op);
+	runtime("PP_LEAVETRY;");
+    	return $op->next;
+}
+
 sub pp_grepstart {
     my $op = shift;
     if ($need_freetmps && $freetmps_each_loop) {
@@ -1009,7 +1158,13 @@ sub pp_grepstart {
 	$need_freetmps = 0;
     }
     write_back_stack();
-    doop($op);
+    my $sym= doop($op);
+    my $next=$op->next;
+    $next->save;
+    my $nexttonext=$next->next;
+    $nexttonext->save;
+    runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
+		    label($nexttonext)));
     return $op->next->other;
 }
 
@@ -1020,7 +1175,15 @@ sub pp_mapstart {
 	$need_freetmps = 0;
     }
     write_back_stack();
-    doop($op);
+    # pp_mapstart can return either op_next->op_next or op_next->op_other and
+    # we need to be able to distinguish the two at runtime. 
+    my $sym= doop($op);
+    my $next=$op->next;
+    $next->save;
+    my $nexttonext=$next->next;
+    $nexttonext->save;
+    runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
+		    label($nexttonext)));
     return $op->next->other;
 }
 
@@ -1037,7 +1200,7 @@ sub pp_grepwhile {
     # 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)));
+    runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next)));
     $know_op = 0;
     return $op->other;
 }
@@ -1051,7 +1214,7 @@ sub pp_return {
     write_back_lexicals(REGISTER|TEMPORARY);
     write_back_stack();
     doop($op);
-    runtime("PUTBACK;", "return 0;");
+    runtime("PUTBACK;", "return PL_op;");
     $know_op = 0;
     return $op->next;
 }
@@ -1065,30 +1228,30 @@ sub nyi {
 sub pp_range {
     my $op = shift;
     my $flags = $op->flags;
-    if (!($flags & OPf_KNOW)) {
+    if (!($flags & OPf_WANT)) {
 	error("context of range unknown at compile-time");
     }
     write_back_lexicals();
     write_back_stack();
-    if (!($flags & OPf_LIST)) {
+    unless (($flags & OPf_WANT)== OPf_WANT_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);
+	runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;",
+			$op->targ, label($op->other));
+	unshift(@bblock_todo, $op->other);
     }
-    return $op->true;
+    return $op->next;
 }
 
 sub pp_flip {
     my $op = shift;
     my $flags = $op->flags;
-    if (!($flags & OPf_KNOW)) {
+    if (!($flags & OPf_WANT)) {
 	error("context of flip unknown at compile-time");
     }
-    if ($flags & OPf_LIST) {
-	return $op->first->false;
+    if (($flags & OPf_WANT)==OPf_WANT_LIST) {
+	return $op->first->other;
     }
     write_back_lexicals();
     write_back_stack();
@@ -1098,19 +1261,19 @@ sub pp_flip {
     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 (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {"
 	  : "if (SvTRUE(TOPs)) {");
-    runtime("\tsv_setiv(curpad[$rangeix], 1);");
+    runtime("\tsv_setiv(PL_curpad[$rangeix], 1);");
     if ($op->flags & OPf_SPECIAL) {
-	runtime("sv_setiv(curpad[$ix], 1);");
+	runtime("sv_setiv(PL_curpad[$ix], 1);");
     } else {
-	runtime("\tsv_setiv(curpad[$ix], 0);",
+	runtime("\tsv_setiv(PL_curpad[$ix], 0);",
 		"\tsp--;",
-		sprintf("\tgoto %s;", label($op->first->false)));
+		sprintf("\tgoto %s;", label($op->first->other)));
     }
     runtime("}",
-	  qq{sv_setpv(curpad[$ix], "");},
-	    "SETs(curpad[$ix]);");
+	  qq{sv_setpv(PL_curpad[$ix], "");},
+	    "SETs(PL_curpad[$ix]);");
     $know_op = 0;
     return $op->next;
 }
@@ -1237,7 +1400,7 @@ sub pp_subst {
     my $sym = doop($op);
     my $replroot = $op->pmreplroot;
     if ($$replroot) {
-	runtime sprintf("if (op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
+	runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
 			$sym, label($replroot));
 	$op->pmreplstart->save;
 	push(@bblock_todo, $replroot);
@@ -1252,12 +1415,12 @@ sub pp_substcont {
     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);
+    # 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;",
+#   warn "pmopsym = $pmopsym\n";#debug
+    runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
 		    $pmopsym, label($pmop->pmreplstart));
     invalidate_lexicals();
     return $pmop->next;
@@ -1266,6 +1429,9 @@ sub pp_substcont {
 sub default_pp {
     my $op = shift;
     my $ppname = $op->ppaddr;
+    if ($curcop and $need_curcop{$ppname}){
+	$curcop->write_back;
+    }
     write_back_lexicals() unless $skip_lexicals{$ppname};
     write_back_stack() unless $skip_stack{$ppname};
     doop($op);
@@ -1322,7 +1488,12 @@ sub cc {
 	warn sprintf("Basic block analysis at %s\n", timing_info);
     }
     $leaders = find_leaders($root, $start);
-    @bblock_todo = ($start, values %$leaders);
+    my @leaders= keys %$leaders; 
+    if ($#leaders > -1) { 
+    	@bblock_todo = ($start, values %$leaders) ;
+    } else{
+	runtime("return PL_op?PL_op->op_next:0;");
+    }
     if ($debug_timings) {
 	warn sprintf("Compilation at %s\n", timing_info);
     }
@@ -1344,7 +1515,7 @@ sub cc {
 	    $need_freetmps = 0;
 	}
 	if (!$$op) {
-	    runtime("PUTBACK;", "return 0;");
+	    runtime("PUTBACK;","return PL_op;");
 	} elsif ($done{$$op}) {
 	    runtime(sprintf("goto %s;", label($op)));
 	}
@@ -1352,6 +1523,7 @@ sub cc {
     if ($debug_timings) {
 	warn sprintf("Saving runtime at %s\n", timing_info);
     }
+    declare_pad(@padlist) ;
     save_runtime();
 }
 
@@ -1375,17 +1547,32 @@ sub cc_obj {
 
 sub cc_main {
     my @comppadlist = comppadlist->ARRAY;
-    my $curpad_sym = $comppadlist[1]->save;
+    my $curpad_nam  = $comppadlist[0]->save;
+    my $curpad_sym  = $comppadlist[1]->save;
+    my $init_av     = init_av->save; 
     my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
-    save_unused_subs(@unused_sub_packages);
+    # Do save_unused_subs before saving inc_hv
+    save_unused_subs();
     cc_recurse();
 
+    my $inc_hv      = svref_2object(\%INC)->save;
+    my $inc_av      = svref_2object(\@INC)->save;
+    my $amagic_generate= amagic_generation;
     return if $errors;
     if (!defined($module)) {
-	$init->add(sprintf("main_root = s\\_%x;", ${main_root()}),
-		   "main_start = $start;",
-		   "curpad = AvARRAY($curpad_sym);");
+	$init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
+		   "PL_main_start = $start;",
+		   "PL_curpad = AvARRAY($curpad_sym);",
+		   "PL_initav = (AV *) $init_av;",
+		   "GvHV(PL_incgv) = $inc_hv;",
+		   "GvAV(PL_incgv) = $inc_av;",
+		   "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
+		   "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
+		   "PL_amagic_generation= $amagic_generate;",
+		     );
+                 
     }
+    seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output
     output_boilerplate();
     print "\n";
     output_all("perl_init");
@@ -1404,14 +1591,14 @@ XS(boot_$cmodule)
     perl_init();
     ENTER;
     SAVETMPS;
-    SAVESPTR(curpad);
-    SAVESPTR(op);
-    curpad = AvARRAY($curpad_sym);
-    op = $start;
-    pp_main(ARGS);
+    SAVESPTR(PL_curpad);
+    SAVESPTR(PL_op);
+    PL_curpad = AvARRAY($curpad_sym);
+    PL_op = $start;
+    pp_main(aTHX);
     FREETMPS;
     LEAVE;
-    ST(0) = &sv_yes;
+    ST(0) = &PL_sv_yes;
     XSRETURN(1);
 }
 EOT
@@ -1438,13 +1625,13 @@ sub compile {
 	    last OPTION;
 	} elsif ($opt eq "o") {
 	    $arg ||= shift @options;
-	    open(STDOUT, ">$arg") or return "$arg: $!\n";
+	    open(STDOUT, ">$arg") or return "open '>$arg': $!\n";
 	} elsif ($opt eq "n") {
 	    $arg ||= shift @options;
 	    $module_name = $arg;
 	} elsif ($opt eq "u") {
 	    $arg ||= shift @options;
-	    push(@unused_sub_packages, $arg);
+	    mark_unused($arg,undef);
 	} elsif ($opt eq "f") {
 	    $arg ||= shift @options;
 	    my $value = $arg !~ s/^no-//;
@@ -1470,7 +1657,7 @@ sub compile {
 	} elsif ($opt eq "m") {
 	    $arg ||= shift @options;
 	    $module = $arg;
-	    push(@unused_sub_packages, $arg);
+	    mark_unused($arg,undef);
 	} elsif ($opt eq "p") {
 	    $arg ||= shift @options;
 	    $patchlevel = $arg;
@@ -1526,3 +1713,209 @@ sub compile {
 }
 
 1;
+
+__END__
+
+=head1 NAME
+
+B::CC - Perl compiler's optimized C translation backend
+
+=head1 SYNOPSIS
+
+	perl -MO=CC[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+This compiler backend takes Perl source and generates C source code
+corresponding to the flow of your program. In other words, this
+backend is somewhat a "real" compiler in the sense that many people
+think about compilers. Note however that, currently, it is a very
+poor compiler in that although it generates (mostly, or at least
+sometimes) correct code, it performs relatively few optimisations.
+This will change as the compiler develops. The result is that
+running an executable compiled with this backend may start up more
+quickly than running the original Perl program (a feature shared
+by the B<C> compiler backend--see F<B::C>) and may also execute
+slightly faster. This is by no means a good optimising compiler--yet.
+
+=head1 OPTIONS
+
+If there are any non-option arguments, they are taken to be
+names of objects to be saved (probably doesn't work properly yet).
+Without extra arguments, it saves the main program.
+
+=over 4
+
+=item B<-ofilename>
+
+Output to filename instead of STDOUT
+
+=item B<-v>
+
+Verbose compilation (currently gives a few compilation statistics).
+
+=item B<-->
+
+Force end of options
+
+=item B<-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 C<$SIG{BAR} = "foo">.  A better fix, though, is just
+to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
+options. The compiler tries to figure out which packages may possibly
+have subs in which need compiling but the current version doesn't do
+it very well. In particular, it is confused by nested packages (i.e.
+of the form C<A::B>) where package C<A> does not contain any subs.
+
+=item B<-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.
+
+
+=item B<-D>
+
+Debug options (concatenated or separate flags like C<perl -D>).
+
+=item B<-Dr>
+
+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).
+
+=item B<-DO>
+
+Outputs each OP as it's compiled
+
+=item B<-Ds>
+
+Outputs the contents of the shadow stack at each OP
+
+=item B<-Dp>
+
+Outputs the contents of the shadow pad of lexicals as it's loaded for
+each sub or the main program.
+
+=item B<-Dq>
+
+Outputs the name of each fake PP function in the queue as it's about
+to process it.
+
+=item B<-Dl>
+
+Output the filename and line number of each original line of Perl
+code as it's processed (C<pp_nextstate>).
+
+=item B<-Dt>
+
+Outputs timing information of compilation stages.
+
+=item B<-f>
+
+Force optimisations on or off one at a time.
+
+=item B<-ffreetmps-each-bblock>
+
+Delays FREETMPS from the end of each statement to the end of the each
+basic block.
+
+=item B<-ffreetmps-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.
+
+=item B<-fomit-taint>
+
+Omits generating code for handling perl's tainting mechanism.
+
+=item B<-On>
+
+Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
+Currently, B<-O1> sets B<-ffreetmps-each-bblock> and B<-O2>
+sets B<-ffreetmps-each-loop>.
+
+=back
+
+=head1 EXAMPLES
+
+        perl -MO=CC,-O2,-ofoo.c foo.pl
+        perl cc_harness -o foo foo.c
+
+Note that C<cc_harness> lives in the C<B> subdirectory of your perl
+library directory. The utility called C<perlcc> may also be used to
+help make use of this compiler.
+
+        perl -MO=CC,-mFoo,-oFoo.c Foo.pm
+        perl cc_harness -shared -c -o Foo.so Foo.c
+
+=head1 BUGS
+
+Plenty. Current status: experimental.
+
+=head1 DIFFERENCES
+
+These aren't really bugs but they are constructs which are heavily
+tied to perl's compile-and-go implementation and with which this
+compiler backend cannot cope.
+
+=head2 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.
+
+=head2 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.
+
+=head2 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.
+
+=head2 Deprecated features
+
+Features of standard perl such as C<$[> which have been deprecated
+in standard perl since Perl5 was released have not been implemented
+in the compiler.
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+
+=cut