diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | cc_runtime.h | 40 | ||||
| -rw-r--r-- | ext/B/B/C.pm | 6 | ||||
| -rw-r--r-- | ext/B/B/CC.pm | 39 | ||||
| -rw-r--r-- | ext/B/B/Stash.pm | 29 | ||||
| -rw-r--r-- | lib/Test/Harness.pm | 2 | ||||
| -rw-r--r-- | utils/perlcc.PL | 12 |
7 files changed, 103 insertions, 26 deletions
@@ -170,6 +170,7 @@ ext/B/B/Disassembler.pm Compiler Disassembler backend ext/B/B/Lint.pm Compiler Lint backend ext/B/B/Showlex.pm Compiler Showlex backend ext/B/B/Stackobj.pm Compiler stack objects support functions +ext/B/B/Stash.pm Compiler module to identify stashes ext/B/B/Terse.pm Compiler Terse backend ext/B/B/Xref.pm Compiler Xref backend ext/B/B/assemble Assemble compiler bytecode diff --git a/cc_runtime.h b/cc_runtime.h index 9a01ff8335..5b6d2c7287 100644 --- a/cc_runtime.h +++ b/cc_runtime.h @@ -59,13 +59,39 @@ SPAGAIN; \ } while (0) -#define PP_ENTERTRY(jmpbuf,label) do { \ - dJMPENV; \ +#define B_JMPENV_PUSH(cur_env,v) \ + STMT_START { \ + cur_env.je_prev = PL_top_env; \ + OP_REG_TO_MEM; \ + cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, 1); \ + OP_MEM_TO_REG; \ + PL_top_env = &cur_env; \ + cur_env.je_mustcatch = FALSE; \ + (v) = cur_env.je_ret; \ + } STMT_END +#define B_JMPENV_POP(cur_env) \ + STMT_START { PL_top_env = cur_env.je_prev; } STMT_END + +#define B_JMPENV_JUMP(cur_env,v) \ + STMT_START { \ + OP_REG_TO_MEM; \ + if (PL_top_env->je_prev) \ + PerlProc_longjmp(PL_top_env->je_buf, (v)); \ + if ((v) == 2) \ + PerlProc_exit(STATUS_NATIVE_EXPORT); \ + PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); \ + PerlProc_exit(1); \ + } STMT_END + + +#define PP_ENTERTRY(jmpbuf,label) { \ int ret; \ - JMPENV_PUSH(ret); \ + B_JMPENV_PUSH(jmpbuf,ret); \ switch (ret) { \ - case 1: JMPENV_POP; JMPENV_JUMP(1); \ - case 2: JMPENV_POP; JMPENV_JUMP(2); \ - case 3: JMPENV_POP; SPAGAIN; goto label;\ - } \ + case 1: B_JMPENV_POP(jmpbuf); B_JMPENV_JUMP(jmpbuf,1); \ + case 2: B_JMPENV_POP(jmpbuf); B_JMPENV_JUMP(jmpbuf,2); \ + case 3: B_JMPENV_POP(jmpbuf); SPAGAIN; goto label;\ + } \ } while (0) + +#define PP_LEAVETRY PL_top_env=PL_top_env->je_prev diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm index 67b20b965a..759b9cd8a7 100644 --- a/ext/B/B/C.pm +++ b/ext/B/B/C.pm @@ -1301,12 +1301,6 @@ sub descend_marked_unused { } } -sub descend_marked_unused { - foreach my $pack (keys %unused_sub_packages) - { - mark_package($pack); - } -} sub save_main { warn "Starting compile\n"; diff --git a/ext/B/B/CC.pm b/ext/B/B/CC.pm index 08429cb0a7..d44a119222 100644 --- a/ext/B/B/CC.pm +++ b/ext/B/B/CC.pm @@ -8,10 +8,10 @@ package B::CC; use strict; use B qw(main_start main_root class comppadlist peekop svref_2object - timing_info init_av + timing_info init_av sv_undef OPf_WANT_LIST OPf_WANT OPf_MOD OPf_STACKED OPf_SPECIAL OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV - OPpDEREF OPpFLIP_LINENUM G_ARRAY + 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 @@ -444,7 +444,7 @@ sub doop { sub gimme { my $op = shift; my $flags = $op->flags; - return (($flags & OPf_WANT) ? ($flags & OPf_WANT_LIST) : "dowantarray()"); + return (($flags & OPf_WANT) ? (($flags & OPf_WANT)== OPf_WANT_LIST? G_ARRAY:G_SCALAR) : "dowantarray()"); } # @@ -459,10 +459,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; } @@ -921,7 +923,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);"); @@ -941,6 +943,20 @@ sub pp_entersub { invalidate_lexicals(REGISTER|TEMPORARY); return $op->next; } +sub pp_formline { + my $op = shift; + my $ppname = $op->ppaddr; + write_label($op); + 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 != ($sym)->op_next && PL_op != (OP*)0 ){"); + runtime( sprintf("goto %s;",label($op))); + runtime("}"); + return $op->next; +} sub pp_goto{ @@ -996,12 +1012,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) { diff --git a/ext/B/B/Stash.pm b/ext/B/B/Stash.pm new file mode 100644 index 0000000000..42c8bc0fd3 --- /dev/null +++ b/ext/B/B/Stash.pm @@ -0,0 +1,29 @@ +# Stash.pm -- show what stashes are loaded +# vishalb@hotmail.com +package B::Stash; + +BEGIN { %Seen = %INC } + +END { + my @arr=scan($main::{"main::"}); + @arr=map{s/\:\:$//;$_;} @arr; + print "-umain,-u", join (",-u",@arr) ,"\n"; +} +sub scan{ + my $start=shift; + my @return; + foreach my $key ( keys %{$start}){ + if ($key =~ /::$/){ + unless ($start eq ${$start}{$key} or $key eq "B::" ){ + push @return, $key ; + foreach my $subscan ( scan(${$start}{$key})){ + push @return, "$key".$subscan; + } + } + } + } + return @return; +} +1; + + diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm index 738f36d4fc..71c0c1c1ce 100644 --- a/lib/Test/Harness.pm +++ b/lib/Test/Harness.pm @@ -82,7 +82,7 @@ sub runtests { $s .= q[ "-T"] if $first =~ /^#!.*\bperl.*-\w*T/; $fh->close or print "can't close $test. $!\n"; my $cmd = ($ENV{'COMPILE_TEST'})? -"./perl -I../lib ../utils/perlcc $test -run -verbose dcf -log ./compilelog |" +"./perl -I../lib ../utils/perlcc $test -run 2>> ./compilelog |" : "$^X $s $test|"; $cmd = "MCR $cmd" if $^O eq 'VMS'; $fh->open($cmd) or print "can't run $test. $!\n"; diff --git a/utils/perlcc.PL b/utils/perlcc.PL index b214645ad9..2ea822b2b4 100644 --- a/utils/perlcc.PL +++ b/utils/perlcc.PL @@ -223,8 +223,11 @@ sub _createCode if (@_ == 2) # compiling a program { - _print( "$^X -I@INC -MO=CC,-o$generated_cfile $file\n", 36); - $return = _run("$ -I@INC -MO=CC,-o$generated_cfile $file", 9); + _print( "$^X -I@INC -MB::Stash -c $file\n", 36); + my $stash=`$^X -I@INC -MB::Stash -c $file 2>/dev/null|tail -1`; + chomp $stash; + _print( "$^X -I@INC -MO=CC,$stash,-o$generated_cfile $file\n", 36); + $return = _run("$ -I@INC -MO=CC,$stash,-o$generated_cfile $file", 9); $return; } else # compiling a shared object @@ -311,9 +314,10 @@ sub _ccharness } my @sharedobjects = _getSharedObjects($sourceprog); + my $dynaloader="$Config{'installarchlib'}/auto/DynaLoader/DynaLoader.a"; my $cccmd = - "$Config{cc} @Config{qw(ccflags optimize)} $incdir @sharedobjects @args $linkargs"; + "$Config{cc} @Config{qw(ccflags optimize)} $incdir @sharedobjects @args $dynaloader $linkargs"; _print ("$cccmd\n", 36); @@ -558,7 +562,7 @@ sub _checkopts && $options->{'gen'}) { push(@errors, -"ERROR: The options '-regex', '-run', and '-o' are incompatible with '-gen'. +"ERROR: The options '-regex', ' -c -run', and '-o' are incompatible with '-gen'. '-gen' says to stop at C generation, and the other three modify the compilation and/or running process!\n"); } |