X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FB%2FB%2FCC.pm;h=cf0e81f92e9932a6cdc7b12ae4ff5b23e529f9c2;hb=87d7fd28459b8274079ce3260d3e07e306aa70d8;hp=9991d8e70078feba911450fea7c743bcc60d0cba;hpb=81009501838bbdb5cbd808a07c703b194ef32869;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/B/B/CC.pm b/ext/B/B/CC.pm index 9991d8e..cf0e81f 100644 --- a/ext/B/B/CC.pm +++ b/ext/B/B/CC.pm @@ -8,34 +8,19 @@ 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 @@ -66,6 +51,9 @@ my %skip_stack; # Hash of PP names which don't need write_back_stack 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)) { @@ -73,11 +61,6 @@ BEGIN { } } -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); @@ -111,12 +94,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 pp_method); sub debug { if ($debug_runtime) { warn(@_); } else { - runtime(map { chomp; "/* $_ */"} @_); + my @tmp=@_; + runtime(map { chomp; "/* $_ */"} @tmp); } } @@ -139,7 +127,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"; @@ -167,7 +155,7 @@ sub init_pp { 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; } @@ -200,7 +188,7 @@ sub top_int { @stack ? $stack[-1]->as_int : "TOPi" } 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" } @@ -208,7 +196,7 @@ sub pop_numeric { @stack ? (pop @stack)->as_numeric : "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. @@ -228,6 +216,31 @@ 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; @@ -350,8 +363,9 @@ sub dopoptoloop { 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; @@ -360,7 +374,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 (@_) { @@ -416,12 +430,22 @@ sub load_pad { } $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 # @@ -461,7 +485,7 @@ sub doop { 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()"); } # @@ -476,10 +500,12 @@ sub pp_null { 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; } @@ -499,8 +525,10 @@ sub pp_and { 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--;"); } @@ -513,11 +541,13 @@ sub pp_or { 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--;"); } @@ -526,13 +556,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 { @@ -567,7 +598,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) { @@ -584,15 +615,48 @@ sub pp_dbstate { 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; @@ -666,11 +730,15 @@ sub numeric_binop { } } 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 { @@ -694,6 +762,60 @@ sub numeric_binop { 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) { @@ -789,7 +911,6 @@ BEGIN { 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"); @@ -808,12 +929,11 @@ 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 - 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) } @@ -857,7 +977,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 { @@ -870,7 +990,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 { @@ -878,7 +1002,7 @@ sub pp_sassign { } 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);"); @@ -887,7 +1011,7 @@ sub pp_sassign { } elsif ($type == T_DOUBLE) { $dst->set_double("SvNV(sv)"); } else { - runtime("SvSetSV($dst->{sv}, sv);"); + runtime("SvSetMagicSV($dst->{sv}, sv);"); $dst->invalidate; } } @@ -922,6 +1046,7 @@ sub pp_preinc { return $op->next; } + sub pp_pushmark { my $op = shift; write_back_stack(); @@ -933,7 +1058,7 @@ sub pp_list { 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);"); @@ -943,21 +1068,57 @@ sub pp_list { 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); @@ -965,7 +1126,7 @@ sub pp_leavewrite { 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); @@ -979,6 +1140,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); @@ -986,9 +1148,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; @@ -996,12 +1173,19 @@ sub pp_entertry { 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) { @@ -1009,7 +1193,14 @@ sub pp_grepstart { $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; } @@ -1020,7 +1211,16 @@ sub pp_mapstart { $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; } @@ -1037,6 +1237,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; @@ -1051,7 +1252,7 @@ sub pp_return { 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; } @@ -1065,30 +1266,31 @@ sub nyi { 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(); @@ -1104,9 +1306,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], "");}, @@ -1175,6 +1378,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; } @@ -1198,6 +1402,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; } @@ -1226,6 +1431,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; } @@ -1237,6 +1443,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; @@ -1252,11 +1459,12 @@ sub pp_substcont { 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(); @@ -1265,7 +1473,10 @@ 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; + } write_back_lexicals() unless $skip_lexicals{$ppname}; write_back_stack() unless $skip_stack{$ppname}; doop($op); @@ -1279,7 +1490,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; } @@ -1301,6 +1512,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 { @@ -1314,15 +1526,26 @@ 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) { 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); } @@ -1332,7 +1555,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;"); @@ -1344,14 +1567,16 @@ sub cc { $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(); } @@ -1375,17 +1600,32 @@ sub cc_obj { 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"); @@ -1404,11 +1644,11 @@ 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(ARGS); + pp_main(aTHX); FREETMPS; LEAVE; ST(0) = &PL_sv_yes; @@ -1444,7 +1684,7 @@ sub compile { $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-//; @@ -1470,7 +1710,7 @@ sub compile { } 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;