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);
+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);
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
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 );
sub debug {
if ($debug_runtime) {
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 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;
if (@stack >= 1) {
my $bool = pop_bool();
write_back_stack();
- runtime(sprintf("if (!$bool) goto %s;", label($next)));
+ runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next)));
} else {
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)));
+ runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }",
+ $bool, label($next)));
} else {
runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
"*sp--;");
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_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_sort { $curcop->write_back; default_pp(@_) }
+#sub pp_caller { $curcop->write_back; default_pp(@_) }
+#sub pp_reset { $curcop->write_back; default_pp(@_) }
sub pp_gv {
my $op = shift;
}
} 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 {
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)(ARGS);");
+ runtime("SPAGAIN;}");
$know_op = 0;
invalidate_lexicals(REGISTER|TEMPORARY);
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);
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;
}
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
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;
+ 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);
$need_freetmps = 0;
}
if (!$$op) {
- runtime("PUTBACK;", "return 0;");
+ runtime("PUTBACK;","return PL_op;");
} elsif ($done{$$op}) {
runtime(sprintf("goto %s;", label($op)));
}
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 $inc_hv = svref_2object(\%INC)->save;
+ my $inc_av = svref_2object(\@INC)->save;
my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
- save_unused_subs(@unused_sub_packages);
+ save_unused_subs();
cc_recurse();
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 = $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));",
+ );
+
}
+ seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output
output_boilerplate();
print "\n";
output_all("perl_init");
$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