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;
#
%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);
}
}
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";
}
}
+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;
sub error {
my $format = shift;
- my $file = $curcop->[0]->filegv->SV->PV;
+ my $file = $curcop->[0]->file;
my $line = $curcop->[0]->line;
$errors++;
if (@_) {
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--;");
}
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--;");
}
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 {
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) {
}
#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:
#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 optree surgery required.
- my $root=$op->first->sibling->first;
- my $start=$root->first;
+ 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;
- $start->save;
- my $sym=objsym($start);
- my $fakeop=cc_queue("pp_sort".$$op,$root,$start);
- $init->add(sprintf("($sym)->op_next=%s;",$fakeop));
- }
+ 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_leavesub{
- my $op = shift;
- my $ppname = $op->ppaddr;
- 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("}");
+ write_back_lexicals();
+ write_back_stack();
doop($op);
return $op->next;
-}
-
+}
sub pp_gv {
my $op = shift;
my $gvsym = $op->gv->save;
# 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
($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 {
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 {
return $op->next;
}
+
sub pp_pushmark {
my $op = shift;
write_back_stack();
# 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;
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);
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);
}
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;
$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;
$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;
# 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;
# 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 {
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();
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], "");},
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;
}
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;
}
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;
}
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;
# 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();
sub default_pp {
my $op = shift;
- my $ppname = $op->ppaddr;
+ my $ppname = "pp_" . $op->name;
if ($curcop and $need_curcop{$ppname}){
$curcop->write_back;
}
sub compile_op {
my $op = shift;
- my $ppname = $op->ppaddr;
+ my $ppname = "pp_" . $op->name;
if (exists $ignore_op{$ppname}) {
return $op->next;
}
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 {
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) {
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;");
if (!$$op) {
runtime("PUTBACK;","return PL_op;");
} elsif ($done{$$op}) {
+ save_or_restore_lexical_state($$op);
runtime(sprintf("goto %s;", label($op)));
}
}
$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));",
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);
projects / p5sagit/p5-mst-13.2.git / blobdiff