get Compiler "working" under useithreads

p4raw-id: //depot/perl@5178

5 files changed, 134 insertions, 46 deletions

diff --git a/ext/B/B.pm b/ext/B/B.pm
index 4512d916e6..03db1053b0 100644
--- a/ext/B/B.pm
+++ b/ext/B/B.pm
@@ -654,8 +654,6 @@ This returns the op description from the global C PL_op_desc array
 
 =item sv
 
-=item gv
-
 =back
 
 =head2 B::PADOP METHOD
diff --git a/ext/B/B.xs b/ext/B/B.xs
index df0b501075..ba16dfa195 100644
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -95,6 +95,11 @@ cc_opclass(pTHX_ OP *o)
     if (o->op_type == OP_SASSIGN)
 	return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
 
+#ifdef USE_ITHREADS
+    if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
+	return OPc_PADOP;
+#endif
+
     switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
     case OA_BASEOP:
 	return OPc_BASEOP;
@@ -685,8 +690,7 @@ PMOP_precomp(o)
 	if (rx)
 	    sv_setpvn(ST(0), rx->precomp, rx->prelen);
 
-#define SVOP_sv(o)	cSVOPx_sv(o)
-#define SVOP_gv(o)	cGVOPx_gv(o)
+#define SVOP_sv(o)	cSVOPo->op_sv
 
 MODULE = B	PACKAGE = B::SVOP		PREFIX = SVOP_
 
@@ -694,10 +698,6 @@ B::SV
 SVOP_sv(o)
 	B::SVOP	o
 
-B::GV
-SVOP_gv(o)
-	B::SVOP	o
-
 #define PADOP_padix(o)	o->op_padix
 #define PADOP_sv(o)	(o->op_padix ? PL_curpad[o->op_padix] : Nullsv)
 #define PADOP_gv(o)	((o->op_padix \
diff --git a/ext/B/B/CC.pm b/ext/B/B/CC.pm
index cf0e81f92e..c5ca2a3df5 100644
--- a/ext/B/B/CC.pm
+++ b/ext/B/B/CC.pm
@@ -6,6 +6,7 @@
 #      License or the Artistic License, as specified in the README file.
 #
 package B::CC;
+use Config;
 use strict;
 use B qw(main_start main_root class comppadlist peekop svref_2object
 	timing_info init_av sv_undef amagic_generation 
@@ -223,7 +224,8 @@ sub save_or_restore_lexical_state {
 		next unless ref($lex);
 		${$lexstate{$bblock}}{$lex->{iv}} = $lex->{flags} ;
 	}
-    }else{
+    }
+    else {
     	foreach my $lex (@pad) {
 	    next unless ref($lex);
 	    my $old_flags=${$lexstate{$bblock}}{$lex->{iv}}  ;
@@ -586,9 +588,16 @@ sub pp_padsv {
 sub pp_const {
     my $op = shift;
     my $sv = $op->sv;
-    my $obj = $constobj{$$sv};
-    if (!defined($obj)) {
-	$obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
+    my $obj;
+    # constant could be in the pad (under useithreads)
+    if ($$sv) {
+	$obj = $constobj{$$sv};
+	if (!defined($obj)) {
+	    $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
+	}
+    }
+    else {
+	$obj = $pad[$op->targ];
     }
     push(@stack, $obj);
     return $op->next;
@@ -656,10 +665,17 @@ sub pp_sort {
     write_back_stack();
     doop($op);
     return $op->next;
-}              
+}
+
 sub pp_gv {
     my $op = shift;
-    my $gvsym = $op->gv->save;
+    my $gvsym;
+    if ($Config{useithreads}) {
+	$gvsym = $pad[$op->padix]->as_sv;
+    }
+    else {
+	$gvsym = $op->gv->save;
+    }
     write_back_stack();
     runtime("XPUSHs((SV*)$gvsym);");
     return $op->next;
@@ -667,7 +683,13 @@ sub pp_gv {
 
 sub pp_gvsv {
     my $op = shift;
-    my $gvsym = $op->gv->save;
+    my $gvsym;
+    if ($Config{useithreads}) {
+	$gvsym = $pad[$op->padix]->as_sv;
+    }
+    else {
+	$gvsym = $op->gv->save;
+    }
     write_back_stack();
     if ($op->private & OPpLVAL_INTRO) {
 	runtime("XPUSHs(save_scalar($gvsym));");
@@ -679,7 +701,13 @@ sub pp_gvsv {
 
 sub pp_aelemfast {
     my $op = shift;
-    my $gvsym = $op->gv->save;
+    my $gvsym;
+    if ($Config{useithreads}) {
+	$gvsym = $pad[$op->padix]->as_sv;
+    }
+    else {
+	$gvsym = $op->gv->save;
+    }
     my $ix = $op->private;
     my $flag = $op->flags & OPf_MOD;
     write_back_stack();
diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm
index f8bcc7c8df..cd53c112d8 100644
--- a/ext/B/B/Deparse.pm
+++ b/ext/B/B/Deparse.pm
@@ -8,6 +8,7 @@
 
 package B::Deparse;
 use Carp 'cluck', 'croak';
+use Config;
 use B qw(class main_root main_start main_cv svref_2object opnumber
 	 OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
 	 OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL
@@ -251,18 +252,19 @@ sub walk_sub {
     walk_tree($op, sub {
 	my $op = shift;
 	if ($op->name eq "gv") {
+	    my $gv = $self->maybe_padgv($op);
 	    if ($op->next->name eq "entersub") {
-		next if $self->{'subs_done'}{$ {$op->gv}}++;
-		next if class($op->gv->CV) eq "SPECIAL";
-		$self->todo($op->gv, $op->gv->CV, 0);
-		$self->walk_sub($op->gv->CV);
+		next if $self->{'subs_done'}{$$gv}++;
+		next if class($gv->CV) eq "SPECIAL";
+		$self->todo($gv, $gv->CV, 0);
+		$self->walk_sub($gv->CV);
 	    } elsif ($op->next->name eq "enterwrite"
 		     or ($op->next->name eq "rv2gv"
 			 and $op->next->next->name eq "enterwrite")) {
-		next if $self->{'forms_done'}{$ {$op->gv}}++;
-		next if class($op->gv->FORM) eq "SPECIAL";
-		$self->todo($op->gv, $op->gv->FORM, 1);
-		$self->walk_sub($op->gv->FORM);
+		next if $self->{'forms_done'}{$$gv}++;
+		next if class($gv->FORM) eq "SPECIAL";
+		$self->todo($gv, $gv->FORM, 1);
+		$self->walk_sub($gv->FORM);
 	    }
 	}
     });
@@ -455,7 +457,7 @@ sub deparse_format {
 	$op = $op->sibling; # skip nextstate
 	my @exprs;
 	$kid = $op->first->sibling; # skip pushmark
-	push @text, $kid->sv->PV;
+	push @text, $self->const_sv($kid)->PV;
 	$kid = $kid->sibling;
 	for (; not null $kid; $kid = $kid->sibling) {
 	    push @exprs, $self->deparse($kid, 0);
@@ -984,7 +986,7 @@ sub pp_require {
     if (class($op) eq "UNOP" and $op->first->name eq "const"
 	and $op->first->private & OPpCONST_BARE)
     {
-	my $name = $op->first->sv->PV;
+	my $name = $self->const_sv($op->first)->PV;
 	$name =~ s[/][::]g;
 	$name =~ s/\.pm//g;
 	return "require($name)";
@@ -1008,6 +1010,7 @@ sub pp_scalar {
 sub padval {
     my $self = shift;
     my $targ = shift;
+    #cluck "curcv was undef" unless $self->{curcv};
     return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
 }
 
@@ -1537,7 +1540,7 @@ sub pp_truncate {
     my $fh;
     if ($op->flags & OPf_SPECIAL) {
 	# $kid is an OP_CONST
-	$fh = $kid->sv->PV;
+	$fh = $self->const_sv($kid)->PV;
     } else {
 	$fh = $self->deparse($kid, 6);
         $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
@@ -1876,22 +1879,37 @@ sub pp_threadsv {
     return $self->maybe_local($op, $cx, "\$" .  $threadsv_names[$op->targ]);
 }    
 
+sub maybe_padgv {
+    my $self = shift;
+    my $op = shift;
+    my $gv;
+    if ($Config{useithreads}) {
+	$gv = $self->padval($op->padix);
+    }
+    else {
+	$gv = $op->gv;
+    }
+    return $gv;
+}
+
 sub pp_gvsv {
     my $self = shift;
     my($op, $cx) = @_;
-    return $self->maybe_local($op, $cx, "\$" . $self->gv_name($op->gv));
+    my $gv = $self->maybe_padgv($op);
+    return $self->maybe_local($op, $cx, "\$" . $self->gv_name($gv));
 }
 
 sub pp_gv {
     my $self = shift;
     my($op, $cx) = @_;
-    return $self->gv_name($op->gv);
+    my $gv = $self->maybe_padgv($op);
+    return $self->gv_name($gv);
 }
 
 sub pp_aelemfast {
     my $self = shift;
     my($op, $cx) = @_;
-    my $gv = $op->gv;
+    my $gv = $self->maybe_padgv($op);
     return "\$" . $self->gv_name($gv) . "[" . $op->private . "]";
 }
 
@@ -1927,7 +1945,7 @@ sub pp_rv2av {
     my($op, $cx) = @_;
     my $kid = $op->first;
     if ($kid->name eq "const") { # constant list
-	my $av = $kid->sv;
+	my $av = $self->const_sv($kid);
 	return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
     } else {
 	return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
@@ -2083,13 +2101,13 @@ sub method {
     }
     $obj = $self->deparse($obj, 24);
     if ($meth->name eq "method_named") {
-	$meth = $meth->sv->PV;
+	$meth = $self->const_sv($meth)->PV;
     } else {
 	$meth = $meth->first;
 	if ($meth->name eq "const") {
 	    # As of 5.005_58, this case is probably obsoleted by the
 	    # method_named case above
-	    $meth = $meth->sv->PV; # needs to be bare
+	    $meth = $self->const_sv($meth)->PV; # needs to be bare
 	} else {
 	    $meth = $self->deparse($meth, 1);
 	}
@@ -2202,7 +2220,7 @@ sub pp_entersub {
 	$amper = "&";
 	$kid = "{" . $self->deparse($kid, 0) . "}";
     } elsif ($kid->first->name eq "gv") {
-	my $gv = $kid->first->gv;
+	my $gv = $self->maybe_padgv($kid->first);
 	if (class($gv->CV) ne "SPECIAL") {
 	    $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
 	}
@@ -2347,13 +2365,23 @@ sub const {
     }
 }
 
+sub const_sv {
+    my $self = shift;
+    my $op = shift;
+    my $sv = $op->sv;
+    # the constant could be in the pad (under useithreads)
+    $sv = $self->padval($op->targ) unless $$sv;
+    return $sv;
+}
+
 sub pp_const {
     my $self = shift;
     my($op, $cx) = @_;
 #    if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting 
-#	return $op->sv->PV;
+#	return $self->const_sv($op)->PV;
 #    }
-    return const($op->sv);
+    my $sv = $self->const_sv($op);
+    return const($sv);
 }
 
 sub dq {
@@ -2361,7 +2389,7 @@ sub dq {
     my $op = shift;
     my $type = $op->name;
     if ($type eq "const") {
-	return uninterp(escape_str(unback($op->sv->PV)));
+	return uninterp(escape_str(unback($self->const_sv($op)->PV)));
     } elsif ($type eq "concat") {
 	return $self->dq($op->first) . $self->dq($op->last);
     } elsif ($type eq "uc") {
@@ -2650,7 +2678,7 @@ sub re_dq {
     my $op = shift;
     my $type = $op->name;
     if ($type eq "const") {
-	return uninterp($op->sv->PV);
+	return uninterp($self->const_sv($op)->PV);
     } elsif ($type eq "concat") {
 	return $self->re_dq($op->first) . $self->re_dq($op->last);
     } elsif ($type eq "uc") {
diff --git a/ext/B/B/Xref.pm b/ext/B/B/Xref.pm
index 53b655c82e..0a5ceabda1 100644
--- a/ext/B/B/Xref.pm
+++ b/ext/B/B/Xref.pm
@@ -85,6 +85,7 @@ Malcolm Beattie, mbeattie@sable.ox.ac.uk.
 =cut
 
 use strict;
+use Config;
 use B qw(peekop class comppadlist main_start svref_2object walksymtable
          OPpLVAL_INTRO SVf_POK
         );
@@ -133,10 +134,10 @@ sub process {
 
 sub load_pad {
     my $padlist = shift;
-    my ($namelistav, @namelist, $ix);
+    my ($namelistav, $vallistav, @namelist, $ix);
     @pad = ();
     return if class($padlist) eq "SPECIAL";
-    ($namelistav) = $padlist->ARRAY;
+    ($namelistav,$vallistav) = $padlist->ARRAY;
     @namelist = $namelistav->ARRAY;
     for ($ix = 1; $ix < @namelist; $ix++) {
 	my $namesv = $namelist[$ix];
@@ -144,6 +145,17 @@ sub load_pad {
 	my ($type, $name) = $namesv->PV =~ /^(.)([^\0]*)(\0.*)?$/;
 	$pad[$ix] = ["(lexical)", $type, $name];
     }
+    if ($Config{useithreads}) {
+	my (@vallist);
+	@vallist = $vallistav->ARRAY;
+	for ($ix = 1; $ix < @vallist; $ix++) {
+	    my $valsv = $vallist[$ix];
+	    next unless class($valsv) eq "GV";
+	    # these pad GVs don't have corresponding names, so same @pad
+	    # array can be used without collisions
+	    $pad[$ix] = [$valsv->STASH->NAME, "*", $valsv->NAME];
+	}
+    }
 }
 
 sub xref {
@@ -229,23 +241,45 @@ sub pp_rv2gv { deref($top, "*"); }
 
 sub pp_gvsv {
     my $op = shift;
-    my $gv = $op->gv;
-    $top = [$gv->STASH->NAME, '$', $gv->NAME];
+    my $gv;
+    if ($Config{useithreads}) {
+	$top = $pad[$op->padix];
+	$top = UNKNOWN unless $top;
+	$top->[1] = '$';
+    }
+    else {
+	$gv = $op->gv;
+	$top = [$gv->STASH->NAME, '$', $gv->NAME];
+    }
     process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
 }
 
 sub pp_gv {
     my $op = shift;
-    my $gv = $op->gv;
-    $top = [$gv->STASH->NAME, "*", $gv->NAME];
+    my $gv;
+    if ($Config{useithreads}) {
+	$top = $pad[$op->padix];
+	$top = UNKNOWN unless $top;
+	$top->[1] = '*';
+    }
+    else {
+	$gv = $op->gv;
+	$top = [$gv->STASH->NAME, "*", $gv->NAME];
+    }
     process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
 }
 
 sub pp_const {
     my $op = shift;
     my $sv = $op->sv;
-    $top = ["?", "",
-	    (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"];
+    # constant could be in the pad (under useithreads)
+    if ($$sv) {
+	$top = ["?", "",
+		(class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"];
+    }
+    else {
+	$top = $pad[$op->targ];
+    }
 }
 
 sub pp_method {