From: Gurusamy Sarathy Date: Mon, 21 Feb 2000 07:02:16 +0000 (+0000) Subject: get Compiler "working" under useithreads X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=18228111eab2b4346ec4a982338c6a12fe2ee3a2;hp=2ba999ece4e8727143f109b401921cec33e5b6dc;p=p5sagit%2Fp5-mst-13.2.git get Compiler "working" under useithreads p4raw-id: //depot/perl@5178 --- diff --git a/ext/B/B.pm b/ext/B/B.pm index 4512d91..03db105 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 df0b501..ba16dfa1 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 cf0e81f..c5ca2a3 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 f8bcc7c..cd53c11 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 53b655c..0a5ceab 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 {