X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FB%2FB%2FCC.pm;h=c5ca2a3df5bb9f47d20db39a38e55f62d02e83a2;hb=1e1dbab6eed49955498a66ce3beedbd7ea33dc21;hp=d2aae923f06df04dc46a2fca44cfacb3f862d084;hpb=66918de8dd631444b797319b2251d78ebc0b12ef;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/B/B/CC.pm b/ext/B/B/CC.pm index d2aae92..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 @@ -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; @@ -92,13 +95,17 @@ 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); +%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_method); sub debug { if ($debug_runtime) { warn(@_); } else { - runtime(map { chomp; "/* $_ */"} @_); + my @tmp=@_; + runtime(map { chomp; "/* $_ */"} @tmp); } } @@ -121,7 +128,7 @@ sub output_runtime { print qq(#include "cc_runtime.h"\n); foreach $ppdata (@pp_list) { my ($name, $runtime, $declare) = @$ppdata; - print "\nstatic\nPP($name)\n{\n"; + print "\nstatic\nCCPP($name)\n{\n"; my ($type, $varlist, $line); while (($type, $varlist) = each %$declare) { print "\t$type ", join(", ", @$varlist), ";\n"; @@ -210,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; @@ -343,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 (@_) { @@ -494,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--;"); } @@ -510,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--;"); } @@ -521,13 +558,14 @@ 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(); + save_or_restore_lexical_state($$false); runtime(sprintf("if (!$bool) goto %s;", label($false))); - return $op->true; + return $op->other; } sub pp_padsv { @@ -550,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; @@ -562,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) { @@ -580,18 +625,57 @@ sub pp_dbstate { } #default_pp will handle this: -#sub pp_rv2gv { $curcop->write_back; default_pp(@_) } #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_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; + 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; @@ -599,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));"); @@ -611,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(); @@ -861,9 +957,9 @@ 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 @@ -909,7 +1005,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 { @@ -922,7 +1018,11 @@ sub pp_sassign { my $type = $src->{type}; 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 { @@ -974,6 +1074,7 @@ sub pp_preinc { return $op->next; } + sub pp_pushmark { my $op = shift; write_back_stack(); @@ -1015,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; @@ -1035,7 +1137,16 @@ 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); @@ -1057,6 +1168,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); @@ -1064,9 +1176,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; @@ -1099,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; @@ -1118,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; @@ -1136,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; @@ -1173,11 +1303,12 @@ 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->false)); - unshift(@bblock_todo, $op->false); + $op->targ, label($op->other)); + unshift(@bblock_todo, $op->other); } - return $op->true; + return $op->next; } sub pp_flip { @@ -1187,7 +1318,7 @@ sub pp_flip { error("context of flip unknown at compile-time"); } if (($flags & OPf_WANT)==OPf_WANT_LIST) { - return $op->first->false; + return $op->first->other; } write_back_lexicals(); write_back_stack(); @@ -1203,9 +1334,10 @@ 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->false))); + sprintf("\tgoto %s;", label($op->first->other))); } runtime("}", qq{sv_setpv(PL_curpad[$ix], "");}, @@ -1274,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; } @@ -1297,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; } @@ -1325,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; } @@ -1336,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; @@ -1356,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(); @@ -1364,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; } @@ -1381,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; } @@ -1403,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 { @@ -1416,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) { @@ -1439,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;"); @@ -1453,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))); } } @@ -1499,7 +1644,7 @@ sub cc_main { $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}), "PL_main_start = $start;", "PL_curpad = AvARRAY($curpad_sym);", - "PL_initav = $init_av;", + "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));", @@ -1527,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);