package B::CC;
use strict;
use B qw(main_start main_root class comppadlist peekop svref_2object
- timing_info);
-use B::C qw(save_unused_subs objsym init_sections
+ timing_info init_av sv_undef amagic_generation
+ OPf_WANT_LIST OPf_WANT OPf_MOD OPf_STACKED OPf_SPECIAL
+ OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV
+ OPpDEREF OPpFLIP_LINENUM G_ARRAY G_SCALAR
+ CXt_NULL CXt_SUB CXt_EVAL CXt_LOOP CXt_SUBST CXt_BLOCK
+ );
+use B::C qw(save_unused_subs objsym init_sections mark_unused
output_all output_boilerplate output_main);
use B::Bblock qw(find_leaders);
use B::Stackobj qw(:types :flags);
# These should probably be elsewhere
# Flags for $op->flags
-sub OPf_LIST () { 1 }
-sub OPf_KNOW () { 2 }
-sub OPf_MOD () { 32 }
-sub OPf_STACKED () { 64 }
-sub OPf_SPECIAL () { 128 }
-# op-specific flags for $op->private
-sub OPpASSIGN_BACKWARDS () { 64 }
-sub OPpLVAL_INTRO () { 128 }
-sub OPpDEREF_AV () { 32 }
-sub OPpDEREF_HV () { 64 }
-sub OPpDEREF () { OPpDEREF_AV|OPpDEREF_HV }
-sub OPpFLIP_LINENUM () { 64 }
-sub G_ARRAY () { 1 }
-# cop.h
-sub CXt_NULL () { 0 }
-sub CXt_SUB () { 1 }
-sub CXt_EVAL () { 2 }
-sub CXt_LOOP () { 3 }
-sub CXt_SUBST () { 4 }
-sub CXt_BLOCK () { 5 }
my $module; # module name (when compiled with -m)
my %done; # hash keyed by $$op of leaders of basic blocks
my %skip_lexicals; # Hash of PP names which don't need write_back_lexicals
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)) {
}
}
-my @unused_sub_packages; # list of packages (given by -u options) to search
- # explicitly and save every sub we find there, even
- # if apparently unused (could be only referenced from
- # an eval "" or from a $SIG{FOO} = "bar").
-
my ($module_name);
my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime,
$debug_shadow, $debug_queue, $debug_lineno, $debug_timings);
#
%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 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";
declare("SV", "**svp");
map { declare("SV", "*$_") } qw(sv src dst left right);
declare("MAGIC", "*mg");
- $decl->add("static OP * $ppname _((ARGSproto));");
+ $decl->add("static OP * $ppname (pTHX);");
debug "init_pp: $ppname\n" if $debug_queue;
}
sub top_double { @stack ? $stack[-1]->as_double : "TOPn" }
sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" }
sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" }
-sub top_bool { @stack ? $stack[-1]->as_numeric : "SvTRUE(TOPs)" }
+sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" }
sub pop_int { @stack ? (pop @stack)->as_int : "POPi" }
sub pop_double { @stack ? (pop @stack)->as_double : "POPn" }
sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" }
sub pop_bool {
if (@stack) {
- return ((pop @stack)->as_numeric);
+ return ((pop @stack)->as_bool);
} else {
# Careful: POPs has an auto-decrement and SvTRUE evaluates
# its argument more than once.
}
}
+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 dopoptolabel {
my $label = shift;
my $cxix = $#cxstack;
- while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP
- && $cxstack[$cxix]->{label} ne $label) {
+ while ($cxix >= 0 &&
+ ($cxstack[$cxix]->{type} != CXt_LOOP ||
+ $cxstack[$cxix]->{label} ne $label)) {
$cxix--;
}
debug "dopoptolabel: returning $cxix" if $debug_cxstack;
sub error {
my $format = shift;
- my $file = $curcop->[0]->filegv->SV->PV;
+ my $file = $curcop->[0]->file;
my $line = $curcop->[0]->line;
$errors++;
if (@_) {
}
$pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix,
"i_$name", "d_$name");
- declare("IV", $type == T_INT ? "i_$name = 0" : "i_$name");
- declare("double", $type == T_DOUBLE ? "d_$name = 0" : "d_$name");
+
debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad;
}
}
+sub declare_pad {
+ my $ix;
+ for ($ix = 1; $ix <= $#pad; $ix++) {
+ my $type = $pad[$ix]->{type};
+ declare("IV", $type == T_INT ?
+ sprintf("%s=0",$pad[$ix]->{iv}):$pad[$ix]->{iv}) if $pad[$ix]->save_int;
+ declare("double", $type == T_DOUBLE ?
+ sprintf("%s = 0",$pad[$ix]->{nv}):$pad[$ix]->{nv} )if $pad[$ix]->save_double;
+
+ }
+}
#
# Debugging stuff
#
sub gimme {
my $op = shift;
my $flags = $op->flags;
- return (($flags & OPf_KNOW) ? ($flags & OPf_LIST) : "dowantarray()");
+ return (($flags & OPf_WANT) ? (($flags & OPf_WANT)== OPf_WANT_LIST? G_ARRAY:G_SCALAR) : "dowantarray()");
}
#
sub pp_stub {
my $op = shift;
my $gimme = gimme($op);
- if ($gimme != 1) {
+ if ($gimme != G_ARRAY) {
+ my $obj= new B::Stackobj::Const(sv_undef);
+ push(@stack, $obj);
# XXX Change to push a constant sv_undef Stackobj onto @stack
- write_back_stack();
- runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
+ #write_back_stack();
+ #runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
}
return $op->next;
}
if (@stack >= 1) {
my $bool = pop_bool();
write_back_stack();
- runtime(sprintf("if (!$bool) goto %s;", label($next)));
+ 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--;");
}
reload_lexicals();
unshift(@bblock_todo, $next);
if (@stack >= 1) {
- my $obj = pop @stack;
+ my $bool = pop_bool @stack;
write_back_stack();
- runtime(sprintf("if (%s) { XPUSHs(%s); goto %s; }",
- $obj->as_numeric, $obj->as_sv, label($next)));
+ 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) {
return default_pp($op);
}
-sub pp_rv2gv { $curcop->write_back; default_pp(@_) }
-sub pp_bless { $curcop->write_back; default_pp(@_) }
-sub pp_repeat { $curcop->write_back; default_pp(@_) }
+#default_pp will handle this:
+#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_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;
}
} else {
if ($force_int) {
+ my $rightruntime = new B::Pseudoreg ("IV", "riv");
+ runtime(sprintf("$$rightruntime = %s;",$right));
runtime(sprintf("sv_setiv(TOPs, %s);",
- &$operator("TOPi", $right)));
+ &$operator("TOPi", $$rightruntime)));
} else {
+ my $rightruntime = new B::Pseudoreg ("double", "rnv");
+ runtime(sprintf("$$rightruntime = %s;",$right));
runtime(sprintf("sv_setnv(TOPs, %s);",
- &$operator("TOPn", $right)));
+ &$operator("TOPn",$$rightruntime)));
}
}
} else {
return $op->next;
}
+sub pp_ncmp {
+ my ($op) = @_;
+ if ($op->flags & OPf_STACKED) {
+ my $right = pop_numeric();
+ if (@stack >= 1) {
+ my $left = top_numeric();
+ runtime sprintf("if (%s > %s){",$left,$right);
+ $stack[-1]->set_int(1);
+ $stack[-1]->write_back();
+ runtime sprintf("}else if (%s < %s ) {",$left,$right);
+ $stack[-1]->set_int(-1);
+ $stack[-1]->write_back();
+ runtime sprintf("}else if (%s == %s) {",$left,$right);
+ $stack[-1]->set_int(0);
+ $stack[-1]->write_back();
+ runtime sprintf("}else {");
+ $stack[-1]->set_sv("&PL_sv_undef");
+ runtime "}";
+ } else {
+ my $rightruntime = new B::Pseudoreg ("double", "rnv");
+ runtime(sprintf("$$rightruntime = %s;",$right));
+ runtime sprintf(qq/if ("TOPn" > %s){/,$rightruntime);
+ runtime sprintf("sv_setiv(TOPs,1);");
+ runtime sprintf(qq/}else if ( "TOPn" < %s ) {/,$$rightruntime);
+ runtime sprintf("sv_setiv(TOPs,-1);");
+ runtime sprintf(qq/} else if ("TOPn" == %s) {/,$$rightruntime);
+ runtime sprintf("sv_setiv(TOPs,0);");
+ runtime sprintf(qq/}else {/);
+ runtime sprintf("sv_setiv(TOPs,&PL_sv_undef;");
+ runtime "}";
+ }
+ } else {
+ my $targ = $pad[$op->targ];
+ my $right = new B::Pseudoreg ("double", "rnv");
+ my $left = new B::Pseudoreg ("double", "lnv");
+ runtime(sprintf("$$right = %s; $$left = %s;",
+ pop_numeric(), pop_numeric));
+ runtime sprintf("if (%s > %s){",$$left,$$right);
+ $targ->set_int(1);
+ $targ->write_back();
+ runtime sprintf("}else if (%s < %s ) {",$$left,$$right);
+ $targ->set_int(-1);
+ $targ->write_back();
+ runtime sprintf("}else if (%s == %s) {",$$left,$$right);
+ $targ->set_int(0);
+ $targ->write_back();
+ runtime sprintf("}else {");
+ $targ->set_sv("&PL_sv_undef");
+ runtime "}";
+ push(@stack, $targ);
+ }
+ return $op->next;
+}
+
sub sv_binop {
my ($op, $operator, $flags) = @_;
if ($op->flags & OPf_STACKED) {
my $modulo_op = infix_op("%");
my $lshift_op = infix_op("<<");
my $rshift_op = infix_op(">>");
- my $ncmp_op = sub { "($_[0] > $_[1] ? 1 : ($_[0] < $_[1]) ? -1 : 0)" };
my $scmp_op = prefix_op("sv_cmp");
my $seq_op = prefix_op("sv_eq");
my $sne_op = prefix_op("!sv_eq");
# 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
- sub pp_ncmp { numeric_binop($_[0], $ncmp_op, INT_RESULT) }
sub pp_left_shift { int_binop($_[0], $lshift_op) }
sub pp_right_shift { int_binop($_[0], $rshift_op) }
($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 {
}
runtime("SvSETMAGIC(TOPs);");
} else {
- my $dst = pop @stack;
+ my $dst = $stack[-1];
my $type = $dst->{type};
runtime("sv = POPs;");
runtime("MAYBE_TAINT_SASSIGN_SRC(sv);");
} elsif ($type == T_DOUBLE) {
$dst->set_double("SvNV(sv)");
} else {
- runtime("SvSetSV($dst->{sv}, sv);");
+ runtime("SvSetMagicSV($dst->{sv}, sv);");
$dst->invalidate;
}
}
return $op->next;
}
+
sub pp_pushmark {
my $op = shift;
write_back_stack();
my $op = shift;
write_back_stack();
my $gimme = gimme($op);
- if ($gimme == 1) { # sic
+ if ($gimme == G_ARRAY) { # sic
runtime("POPMARK;"); # need this even though not a "full" pp_list
} else {
runtime("PP_LIST($gimme);");
sub pp_entersub {
my $op = shift;
+ $curcop->write_back;
write_back_lexicals(REGISTER|TEMPORARY);
write_back_stack();
my $sym = doop($op);
- runtime("if (PL_op != ($sym)->op_next) PL_op = (*PL_op->op_ppaddr)(ARGS);");
- runtime("SPAGAIN;");
+ runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
+ runtime("PL_op = (*PL_op->op_ppaddr)(aTHX);");
+ runtime("SPAGAIN;}");
$know_op = 0;
invalidate_lexicals(REGISTER|TEMPORARY);
return $op->next;
}
+sub pp_formline {
+ my $op = shift;
+ my $ppname = $op->ppaddr;
+ write_back_lexicals() unless $skip_lexicals{$ppname};
+ write_back_stack() unless $skip_stack{$ppname};
+ my $sym=doop($op);
+ # 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;
+}
+
+sub pp_goto{
+ my $op = shift;
+ my $ppname = $op->ppaddr;
+ write_back_lexicals() unless $skip_lexicals{$ppname};
+ write_back_stack() unless $skip_stack{$ppname};
+ my $sym=doop($op);
+ runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}");
+ invalidate_lexicals() unless $skip_invalidate{$ppname};
+ return $op->next;
+}
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);
my $sym = doop($op);
# XXX Is this the right way to distinguish between it returning
# CvSTART(cv) (via doform) and pop_return()?
- runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(ARGS);");
+ #runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(aTHX);");
runtime("SPAGAIN;");
$know_op = 0;
invalidate_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;
write_back_stack();
my $sym = doop($op);
my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++);
- declare("Sigjmp_buf", $jmpbuf);
+ declare("JMPENV", $jmpbuf);
runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
invalidate_lexicals(REGISTER|TEMPORARY);
return $op->next;
}
+sub pp_leavetry{
+ my $op=shift;
+ default_pp($op);
+ runtime("PP_LEAVETRY;");
+ return $op->next;
+}
+
sub pp_grepstart {
my $op = shift;
if ($need_freetmps && $freetmps_each_loop) {
$need_freetmps = 0;
}
write_back_stack();
- doop($op);
+ my $sym= doop($op);
+ my $next=$op->next;
+ $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;
}
$need_freetmps = 0;
}
write_back_stack();
- doop($op);
+ # pp_mapstart can return either op_next->op_next or op_next->op_other and
+ # we need to be able to distinguish the two at runtime.
+ my $sym= doop($op);
+ my $next=$op->next;
+ $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;
write_back_lexicals(REGISTER|TEMPORARY);
write_back_stack();
doop($op);
- runtime("PUTBACK;", "return 0;");
+ runtime("PUTBACK;", "return PL_op;");
$know_op = 0;
return $op->next;
}
sub pp_range {
my $op = shift;
my $flags = $op->flags;
- if (!($flags & OPf_KNOW)) {
+ if (!($flags & OPf_WANT)) {
error("context of range unknown at compile-time");
}
write_back_lexicals();
write_back_stack();
- if (!($flags & OPf_LIST)) {
+ unless (($flags & OPf_WANT)== OPf_WANT_LIST) {
# 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 {
my $op = shift;
my $flags = $op->flags;
- if (!($flags & OPf_KNOW)) {
+ if (!($flags & OPf_WANT)) {
error("context of flip unknown at compile-time");
}
- if ($flags & OPf_LIST) {
- return $op->first->false;
+ if (($flags & OPf_WANT)==OPf_WANT_LIST) {
+ 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;
write_back_stack();
doop($op);
my $pmop = $op->other;
- warn sprintf("substcont: op = %s, pmop = %s\n",
- peekop($op), peekop($pmop));#debug
-# my $pmopsym = objsym($pmop);
+ # warn sprintf("substcont: op = %s, pmop = %s\n",
+ # peekop($op), peekop($pmop));#debug
+# my $pmopsym = objsym($pmop);
my $pmopsym = $pmop->save; # XXX can this recurse?
- warn "pmopsym = $pmopsym\n";#debug
+# 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;
+ }
write_back_lexicals() unless $skip_lexicals{$ppname};
write_back_stack() unless $skip_stack{$ppname};
doop($op);
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) {
warn sprintf("Basic block analysis at %s\n", timing_info);
}
$leaders = find_leaders($root, $start);
- @bblock_todo = ($start, values %$leaders);
+ my @leaders= keys %$leaders;
+ if ($#leaders > -1) {
+ @bblock_todo = ($start, values %$leaders) ;
+ } else{
+ runtime("return PL_op?PL_op->op_next:0;");
+ }
if ($debug_timings) {
warn sprintf("Compilation at %s\n", timing_info);
}
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;");
$need_freetmps = 0;
}
if (!$$op) {
- runtime("PUTBACK;", "return 0;");
+ runtime("PUTBACK;","return PL_op;");
} elsif ($done{$$op}) {
+ save_or_restore_lexical_state($$op);
runtime(sprintf("goto %s;", label($op)));
}
}
if ($debug_timings) {
warn sprintf("Saving runtime at %s\n", timing_info);
}
+ declare_pad(@padlist) ;
save_runtime();
}
sub cc_main {
my @comppadlist = comppadlist->ARRAY;
- my $curpad_sym = $comppadlist[1]->save;
+ my $curpad_nam = $comppadlist[0]->save;
+ my $curpad_sym = $comppadlist[1]->save;
+ my $init_av = init_av->save;
my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
- save_unused_subs(@unused_sub_packages);
+ # Do save_unused_subs before saving inc_hv
+ save_unused_subs();
cc_recurse();
+ my $inc_hv = svref_2object(\%INC)->save;
+ my $inc_av = svref_2object(\@INC)->save;
+ my $amagic_generate= amagic_generation;
return if $errors;
if (!defined($module)) {
$init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
"PL_main_start = $start;",
- "PL_curpad = AvARRAY($curpad_sym);");
+ "PL_curpad = AvARRAY($curpad_sym);",
+ "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));",
+ "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
+ "PL_amagic_generation= $amagic_generate;",
+ );
+
}
+ seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output
output_boilerplate();
print "\n";
output_all("perl_init");
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(ARGS);
+ pp_main(aTHX);
FREETMPS;
LEAVE;
ST(0) = &PL_sv_yes;
$module_name = $arg;
} elsif ($opt eq "u") {
$arg ||= shift @options;
- push(@unused_sub_packages, $arg);
+ mark_unused($arg,undef);
} elsif ($opt eq "f") {
$arg ||= shift @options;
my $value = $arg !~ s/^no-//;
} elsif ($opt eq "m") {
$arg ||= shift @options;
$module = $arg;
- push(@unused_sub_packages, $arg);
+ mark_unused($arg,undef);
} elsif ($opt eq "p") {
$arg ||= shift @options;
$patchlevel = $arg;
projects / p5sagit/p5-mst-13.2.git / blobdiff