Permalink
Browse files

* C: allow debugging without -MOd=C

  improve package_pv detection for methods, two more tests
* CC: allow debugging without -MOd=CC
  Try to jump from last to unknown block behind.



git-svn-id: http://perl-compiler.googlecode.com/svn/trunk@1098 ed534f1a-1453-0410-ab30-dfc593a8b23c
  • Loading branch information...
1 parent eac02a0 commit 1faa1a5709ad9f24210220d2ce9c4b35ebd14abb Reini Urban committed Jun 15, 2011
Showing with 46 additions and 34 deletions.
  1. +6 −0 Changes
  2. +24 −26 lib/B/C.pm
  3. +3 −1 lib/B/CC.pm
  4. +2 −2 log.modules-5.012003-m
  5. +3 −3 perloptree.pod
  6. +1 −1 t/TESTS
  7. +7 −1 t/testc.sh
View
@@ -3,6 +3,12 @@
The Perl compiler was in CORE from alpha4 until Perl 5.9.4
and worked quite fine with Perl 5.6 and 5.8
+1.35 2011-07-xx rurban
+ * C: allow debugging without -MOd=C
+ improve package_pv detection for methods, two more tests
+ * CC: allow debugging without -MOd=CC
+ Try to jump from last to unknown block behind.
+
1.34 2011-06-12 rurban
* Makefile.PL: fixed make install < 5.13.7
* issue24.t, test.pl, bytecode.t: TODO more failing tests from cpantesters
View
@@ -353,6 +353,11 @@ sub svop_or_padop_pv {
my $op = shift;
my $sv;
if (!$op->can("sv")) {
+ if ($op->can('name') and $op->name eq 'padsv') {
+ my @c = comppadlist->ARRAY;
+ my @pad = $c[1]->ARRAY;
+ return $pad[$op->targ]->PV if $pad[$op->targ] and $pad[$op->targ]->can("PV");
+ }
# $op->can('pmreplroot') fails for 5.14
if (ref($op) eq 'B::PMOP' and $op->pmreplroot->can("sv")) {
$sv = $op->pmreplroot->sv;
@@ -390,7 +395,7 @@ sub svop_or_padop_pv {
} else {
missing:
if ($op->name ne 'method_named') {
- # Called from some svop before method_named. no magic pv string, so a method arg.
+ # Called from first const/padsv before method_named. no magic pv string, so a method arg.
# The first const pv as method_named arg is always the $package_pv.
return $package_pv;
} elsif ($sv->isa("B::IV")) {
@@ -595,7 +600,6 @@ sub save_hek {
wantarray ? ( "$sym", length( pack "a*", $str ) ) : "$sym";
}
-
sub ivx ($) {
my $ivx = shift;
my $ivdformat = $Config{ivdformat};
@@ -675,35 +679,27 @@ my $opsect_common =
sub B::OP::_save_common {
my $op = shift;
- # method_named packages are always const PV sM/BARE.
- # XXX The package name is always the first arg to method_named, but there may appear
- # more arguments in between, even const strings.
+ # compile-time method_named packages are always const PV sM/BARE, they should be optimized.
+ # run-time packages are in gvsv/padsv. This is difficult to optimize.
+ # my Foo $obj = shift; $obj->bar(); # TODO typed $obj
+ # entersub -> pushmark -> package -> args...
+ # See perl -MO=Terse -e '$foo->bar("var")'
+ # See also http://www.perl.com/pub/2000/06/dougpatch.html
if ($op->type > 0 and
- (($op->name eq 'const' and $op->flags == 34)) # or $op->name eq 'gv'
- and (
- ($op->next->can('name') and $op->next->name eq 'method_named') # 0 args
- or
- ($op->next->can('next') and $op->next->next and $op->next->next->can('name')
- and $op->next->next->name eq 'method_named') # 1 arg
- or
- ($op->next->can('next') and $op->next->next and $op->next->next->can('next')
- and $op->next->next->next and $op->next->next->next->can('name')
- and $op->next->next->next->name eq 'method_named') # 2 args
- or
- ($op->next->can('next') and $op->next->next and $op->next->next->can('next')
- and $op->next->next->next and $op->next->next->next->can('next')
- and $op->next->next->next->next and $op->next->next->next->next->can('name')
- and $op->next->next->next->next->name eq 'method_named') # 3 args
- # XXX TODO support more args ...
- )) {
- my $pv = svop_or_padop_pv($op); # XXX HACK! need to store away the pkg pv. Failed since 5.13
+ $op->name eq 'entersub' and $op->first and $op->first->can('name') and
+ $op->first->name eq 'pushmark' and
+ (($op->first->next->name eq 'const' and $op->first->next->flags == 34) # Foo->bar() compile-time lookup
+ or $op->first->next->name eq 'padsv' # $foo->bar() run-time lookup
+ or $op->first->next->name eq 'gvsv')
+ ) {
+ my $pv = svop_or_padop_pv($op->first->next); # XXX need to store away the pkg pv. Failed since 5.13
if ($pv and $pv !~ /[! \(]/) {
$package_pv = $pv;
push_package($package_pv);
- warn "save package_pv \"$package_pv\" for method_name\n" if $debug{cv};
+ warn "save package_pv \"$package_pv\" for method_name\n" if $debug{cv} or $debug{pkg};
}
}
- $prev_op = $op;
+ # $prev_op = $op;
return sprintf(
"s\\_%x, s\\_%x, %s",
${ $op->next },
@@ -978,7 +974,7 @@ sub method_named {
my $name = shift;
return unless $name;
# Note: the pkg PV is unacessible(?) at PL_stack_base+TOPMARK+1.
- # But also at the previous (minus string args) op->sv->PV.
+ # But it is also at the previous (after pushmark, before all args) op->sv->PV.
# We stored it away globally in op->_save_common.
if (ref($name) eq 'B::CV') {
warn $name;
@@ -4585,6 +4581,8 @@ sub mark_unused {
sub compile {
my @options = @_;
+ # Allow debugging in CHECK blocks without Od
+ $DB::single=1 if defined &DB::DB;
my ( $option, $opt, $arg );
my @eval_at_startup;
$B::C::destruct = 1;
View
@@ -2562,7 +2562,7 @@ sub pp_last {
$cxix = dopoptolabel( $op->pv );
if ( $cxix < 0 ) {
warn( sprintf("Warning: Label not found at compile time for \"last %s\"\n", $op->pv ));
- #return default_pp($op); # no optimization
+ return default_pp($op); # no optimization
}
# XXX Add support for "last" to leave non-loop blocks
@@ -2882,6 +2882,8 @@ sub compile_stats {
# Accessible via use B::CC '-ftype-attr'; in user code, or -MB::CC=-O2 on the cmdline
sub import {
my @options = @_;
+ # Allow debugging in CHECK blocks without Od
+ $DB::single=1 if defined &DB::DB;
my ( $option, $opt, $arg );
OPTION:
while ( $option = shift @options ) {
View
@@ -1,4 +1,4 @@
-# B::C::VERSION = 1.32 r1083 M
+# B::C::VERSION = 1.34 r1087 M
# perlversion = 5.012003-m
# path = /opt/local/bin/perl5.12.3
# platform = darwin 64bit multi
@@ -102,7 +102,7 @@ pass IO::String
pass AppConfig
pass UNIVERSAL::require
pass Template::Stash
-# 100 / 100 modules tested with B-C-1.32 - perl-5.012003-m
+# 100 / 100 modules tested with B-C-1.34 - perl-5.012003-m
# pass 100 / 100 (100.0%)
# fail 0 / 100 (0.0%)
# todo 0 / 0 ()
View
@@ -1125,7 +1125,7 @@ If not B<gv> (of the name) and B<method> is used.
The package name is at the top of the stack.
A call stack is added with B<pushmark>.
-1. Static compile time package and method:
+1. Static compile time package ("class") and method:
Class->subname(args...) =>
@@ -1135,7 +1135,7 @@ Class->subname(args...) =>
method_named => "subname"
entersub
-2. Run-time package and compile-time method:
+2. Run-time package ("object") and compile-time method:
$obj->subname(args...) =>
@@ -1156,7 +1156,7 @@ $obj->$meth(args...) =>
method
entersub
-4. Compile-time package and run-time method:
+4. Compile-time package ("class") and run-time method:
Class->$meth(args...) =>
View
@@ -148,7 +148,7 @@ ok
package dummy;sub meth{print "ok"};package main;dummy->meth(1)
>>>>
ok
-######################### 35 methodcall syntax fails #####
+######################### 35 static methodcall #####
my ($rv,%hv);%hv=(key=>\$rv);$rv=\%hv;print "ok";
>>>>
ok
View
@@ -248,7 +248,7 @@ result[33]='ok'
# (Steven Schubiger 2006-02-03 17:24:49 +0100 3967) i.e. 5.8.9 but not 5.8.8
tests[34]='my $x=$ENV{TMPDIR};print "ok"'
result[34]='ok'
-# method_named. fixed with 1.16
+# static method_named. fixed with 1.16
tests[35]='package dummy;sub meth{print "ok"};package main;dummy->meth(1)'
result[35]='ok'
# HV self-ref
@@ -311,6 +311,12 @@ result[70]='ok'
# issue24
tests[71]='dbmopen(%H,q(f),0644);print q(ok);'
result[71]='ok'
+# object call: method_named with args.
+tests[72]='package dummy;sub meth{print "ok"};package main;my dummy $o = bless {},"dummy"; $o->meth("const")'
+result[72]='ok'
+# object call: dynamic method_named with args.
+tests[73]='package dummy;sub meth{print "ok"};package main;my $meth="meth";my $o = bless {},"dummy"; $o->$meth("const")'
+result[73]='ok'
# from here on we test CC specifics only

0 comments on commit 1faa1a5

Please sign in to comment.