Integrate ext/B changes from //depot/cfgperl

p4raw-id: //depot/perl@2550
p4raw-integrated: from //depot/cfgperl@2491 'copy in' ext/B/B.xs
	(@2460..) 'merge in' ext/B/B/C.pm ext/B/B/CC.pm
	ext/B/B/Stackobj.pm (@2524..)

diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm
index bbf49cd..97e3a88 100644 (file)
--- a/ext/B/B/C.pm
+++ b/ext/B/B/C.pm
@@ -1268,9 +1268,17 @@ sub descend_marked_unused {
     }
 }
 
+sub descend_marked_unused {
+    foreach my $pack (keys %unused_sub_packages)
+    {
+       mark_package($pack);
+    }
+}
+ 
 sub save_main {
     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();

diff --git a/ext/B/B/CC.pm b/ext/B/B/CC.pm
index efb17a1..e4f8877 100644 (file)
--- a/ext/B/B/CC.pm
+++ b/ext/B/B/CC.pm
@@ -73,7 +73,6 @@ BEGIN {
     }
 }
 
-
 my ($module_name);
 my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime,
     $debug_shadow, $debug_queue, $debug_lineno, $debug_timings);
@@ -346,8 +345,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;
@@ -662,11 +662,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 {
@@ -1405,6 +1409,7 @@ sub cc_main {
                     );
                  
     }
+    seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output
     output_boilerplate();
     print "\n";
     output_all("perl_init");

diff --git a/ext/B/B/Stackobj.pm b/ext/B/B/Stackobj.pm
index 7760006..09a3e90 100644 (file)
--- a/ext/B/B/Stackobj.pm
+++ b/ext/B/B/Stackobj.pm
@@ -26,6 +26,7 @@ sub SVf_NOK () { 0x20000 }
 sub T_UNKNOWN () { 0 }
 sub T_DOUBLE ()  { 1 }
 sub T_INT ()     { 2 }
+sub T_SPECIAL () { 3 }
 
 # Flags
 sub VALID_INT ()       { 0x01 }
@@ -91,6 +92,7 @@ sub as_bool {
        }
        return sprintf("(SvTRUE(%s))", $obj->as_sv) ;
 }
+
 #
 # Debugging methods
 #
@@ -223,17 +225,21 @@ sub B::Stackobj::Const::new {
        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;
+    if ( ref($sv) eq  "B::SPECIAL" ){
+       $obj->{type}= T_SPECIAL;        
+    }else{
+       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;
 }