Re: [ID 20001204.007] -MO=Deparse -we '{234;}' failing

[p5sagit/p5-mst-13.2.git] / ext / B / B / CC.pm

diff --git a/ext/B/B/CC.pm b/ext/B/B/CC.pm
index f912c41..c5ca2a3 100644 (file)
--- 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 
@@ -53,6 +54,8 @@ 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
 
+my %lexstate;          #state of padsvs at the start of a bblock
+
 BEGIN {
     foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) {
        $ignore_op{$_} = 1;
@@ -95,13 +98,14 @@ sub init_hash { map { $_ => 1 } @_ }
 %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);
+                       pp_enter pp_method);
 
 sub debug {
     if ($debug_runtime) {
        warn(@_);
     } else {
-       runtime(map { chomp; "/* $_ */"} @_);
+       my @tmp=@_;
+       runtime(map { chomp; "/* $_ */"} @tmp);
     }
 }
 
@@ -213,6 +217,32 @@ sub write_back_lexicals {
     }
 }
 
+sub save_or_restore_lexical_state {
+    my $bblock=shift;
+    unless( exists $lexstate{$bblock}){
+       foreach my $lex (@pad) {
+               next unless ref($lex);
+               ${$lexstate{$bblock}}{$lex->{iv}} = $lex->{flags} ;
+       }
+    }
+    else {
+       foreach my $lex (@pad) {
+           next unless ref($lex);
+           my $old_flags=${$lexstate{$bblock}}{$lex->{iv}}  ;
+           next if ( $old_flags eq $lex->{flags});
+           if  (($old_flags & VALID_SV)  && !($lex->{flags} & VALID_SV)){
+               $lex->write_back;
+           }
+           if (($old_flags & VALID_DOUBLE) && !($lex->{flags} & VALID_DOUBLE)){
+                $lex->load_double;
+            }
+            if (($old_flags & VALID_INT) && !($lex->{flags} & VALID_INT)){
+                $lex->load_int;
+            }
+        }
+    }
+}
+
 sub write_back_stack {
     my $obj;
     return unless @stack;
@@ -346,7 +376,7 @@ sub dopoptolabel {
 
 sub error {
     my $format = shift;
-    my $file = $curcop->[0]->filegv->SV->PV;
+    my $file = $curcop->[0]->file;
     my $line = $curcop->[0]->line;
     $errors++;
     if (@_) {
@@ -497,8 +527,10 @@ sub pp_and {
     if (@stack >= 1) {
        my $bool = pop_bool();
        write_back_stack();
+        save_or_restore_lexical_state($$next);
        runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next)));
     } else {
+        save_or_restore_lexical_state($$next);
        runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)),
                "*sp--;");
     }
@@ -513,9 +545,11 @@ sub pp_or {
     if (@stack >= 1) {
        my $bool = pop_bool @stack;
        write_back_stack();
+        save_or_restore_lexical_state($$next);
        runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }",
                        $bool, label($next)));
     } else {
+        save_or_restore_lexical_state($$next);
        runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
                "*sp--;");
     }
@@ -529,6 +563,7 @@ sub pp_cond_expr {
     reload_lexicals();
     my $bool = pop_bool();
     write_back_stack();
+    save_or_restore_lexical_state($$false);
     runtime(sprintf("if (!$bool) goto %s;", label($false)));
     return $op->other;
 }
@@ -553,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;
@@ -565,7 +607,7 @@ sub pp_nextstate {
     my $op = shift;
     $curcop->load($op);
     @stack = ();
-    debug(sprintf("%s:%d\n", $op->filegv->SV->PV, $op->line)) if $debug_lineno;
+    debug(sprintf("%s:%d\n", $op->file, $op->line)) if $debug_lineno;
     runtime("TAINT_NOT;") unless $omit_taint;
     runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;");
     if ($freetmps_each_bblock || $freetmps_each_loop) {
@@ -623,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;
@@ -634,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));");
@@ -646,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();
@@ -1013,6 +1074,7 @@ sub pp_preinc {
     return $op->next;
 }
 
+
 sub pp_pushmark {
     my $op = shift;
     write_back_stack();
@@ -1054,6 +1116,7 @@ sub pp_formline {
     # See comment in pp_grepwhile to see why!
     $init->add("((LISTOP*)$sym)->op_first = $sym;");    
     runtime("if (PL_op == ((LISTOP*)($sym))->op_first){");
+    save_or_restore_lexical_state(${$op->first});
     runtime( sprintf("goto %s;",label($op->first)));
     runtime("}");
     return $op->next;
@@ -1163,6 +1226,7 @@ sub pp_grepstart {
     $next->save;
     my $nexttonext=$next->next;
     $nexttonext->save;
+    save_or_restore_lexical_state($$nexttonext);
     runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
                    label($nexttonext)));
     return $op->next->other;
@@ -1182,6 +1246,7 @@ sub pp_mapstart {
     $next->save;
     my $nexttonext=$next->next;
     $nexttonext->save;
+    save_or_restore_lexical_state($$nexttonext);
     runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
                    label($nexttonext)));
     return $op->next->other;
@@ -1200,6 +1265,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;");
+    save_or_restore_lexical_state($$next);
     runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next)));
     $know_op = 0;
     return $op->other;
@@ -1237,6 +1303,7 @@ sub pp_range {
        # 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;
+        save_or_restore_lexical_state(${$op->other});
        runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;",
                        $op->targ, label($op->other));
        unshift(@bblock_todo, $op->other);
@@ -1267,6 +1334,7 @@ sub pp_flip {
     if ($op->flags & OPf_SPECIAL) {
        runtime("sv_setiv(PL_curpad[$ix], 1);");
     } else {
+       save_or_restore_lexical_state(${$op->first->other});
        runtime("\tsv_setiv(PL_curpad[$ix], 0);",
                "\tsp--;",
                sprintf("\tgoto %s;", label($op->first->other)));
@@ -1338,6 +1406,7 @@ sub pp_next {
     default_pp($op);
     my $nextop = $cxstack[$cxix]->{nextop};
     push(@bblock_todo, $nextop);
+    save_or_restore_lexical_state($$nextop);
     runtime(sprintf("goto %s;", label($nextop)));
     return $op->next;
 }
@@ -1361,6 +1430,7 @@ sub pp_redo {
     default_pp($op);
     my $redoop = $cxstack[$cxix]->{redoop};
     push(@bblock_todo, $redoop);
+    save_or_restore_lexical_state($$redoop);
     runtime(sprintf("goto %s;", label($redoop)));
     return $op->next;
 }
@@ -1389,6 +1459,7 @@ sub pp_last {
     default_pp($op);
     my $lastop = $cxstack[$cxix]->{lastop}->next;
     push(@bblock_todo, $lastop);
+    save_or_restore_lexical_state($$lastop);
     runtime(sprintf("goto %s;", label($lastop)));
     return $op->next;
 }
@@ -1400,6 +1471,7 @@ sub pp_subst {
     my $sym = doop($op);
     my $replroot = $op->pmreplroot;
     if ($$replroot) {
+        save_or_restore_lexical_state($$replroot);
        runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
                        $sym, label($replroot));
        $op->pmreplstart->save;
@@ -1420,6 +1492,7 @@ sub pp_substcont {
 #   my $pmopsym = objsym($pmop);
     my $pmopsym = $pmop->save; # XXX can this recurse?
 #   warn "pmopsym = $pmopsym\n";#debug
+    save_or_restore_lexical_state(${$pmop->pmreplstart});
     runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
                    $pmopsym, label($pmop->pmreplstart));
     invalidate_lexicals();
@@ -1428,7 +1501,7 @@ sub pp_substcont {
 
 sub default_pp {
     my $op = shift;
-    my $ppname = $op->ppaddr;
+    my $ppname = "pp_" . $op->name;
     if ($curcop and $need_curcop{$ppname}){
        $curcop->write_back;
     }
@@ -1445,7 +1518,7 @@ sub default_pp {
 
 sub compile_op {
     my $op = shift;
-    my $ppname = $op->ppaddr;
+    my $ppname = "pp_" . $op->name;
     if (exists $ignore_op{$ppname}) {
        return $op->next;
     }
@@ -1467,6 +1540,7 @@ sub compile_op {
 sub compile_bblock {
     my $op = shift;
     #warn "compile_bblock: ", peekop($op), "\n"; # debug
+    save_or_restore_lexical_state($$op);
     write_label($op);
     $know_op = 0;
     do {
@@ -1480,8 +1554,14 @@ sub compile_bblock {
 sub cc {
     my ($name, $root, $start, @padlist) = @_;
     my $op;
+    if($done{$$start}){ 
+       #warn "repeat=>".ref($start)."$name,\n";#debug
+       $decl->add(sprintf("#define $name  %s",$done{$$start}));
+       return;
+    }
     init_pp($name);
     load_pad(@padlist);
+    %lexstate=();
     B::Pseudoreg->new_scope;
     @cxstack = ();
     if ($debug_timings) {
@@ -1503,7 +1583,7 @@ sub cc {
        next if !defined($op) || !$$op || $done{$$op};
        #warn "...compiling it\n"; # debug
        do {
-           $done{$$op} = 1;
+           $done{$$op} = $name;
            $op = compile_bblock($op);
            if ($need_freetmps && $freetmps_each_bblock) {
                runtime("FREETMPS;");
@@ -1517,6 +1597,7 @@ sub cc {
        if (!$$op) {
            runtime("PUTBACK;","return PL_op;");
        } elsif ($done{$$op}) {
+           save_or_restore_lexical_state($$op);
            runtime(sprintf("goto %s;", label($op)));
        }
     }
@@ -1591,8 +1672,8 @@ XS(boot_$cmodule)
     perl_init();
     ENTER;
     SAVETMPS;
-    SAVESPTR(PL_curpad);
-    SAVESPTR(PL_op);
+    SAVEVPTR(PL_curpad);
+    SAVEVPTR(PL_op);
     PL_curpad = AvARRAY($curpad_sym);
     PL_op = $start;
     pp_main(aTHX);