Re: [patch] optimized constant subs are cool, teach B::Concise about them

Message-ID: <43B9A3F8.8060609@gmail.com>

p4raw-id: //depot/perl@26595

diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm
index ebacec3..c8710ca 100644 (file)
--- a/ext/B/B/Concise.pm
+++ b/ext/B/B/Concise.pm
@@ -164,7 +164,7 @@ sub concise_cv_obj {
 
     $curcv = $cv;
 
-    if (ref($cv->XSUBANY) =~ /B::([INP]V)/) {
+    if (ref($cv->XSUBANY) =~ /B::(\w+)/) {
        print $walkHandle "$name is a constant sub, optimized to a $1\n";
        return;
     }

diff --git a/ext/B/t/concise-xs.t b/ext/B/t/concise-xs.t
index c131436..a90a615 100644 (file)
--- a/ext/B/t/concise-xs.t
+++ b/ext/B/t/concise-xs.t
@@ -115,21 +115,22 @@ BEGIN {
 
 use Getopt::Std;
 use Carp;
-use Test::More tests => ( 0 * !!$Config::Config{useithreads}
+use Test::More tests => ( # per-pkg tests (function ct + require_ok)
+                         40 + 16       # Data::Dumper, Digest::MD5
+                         + 511 + 233   # B::Deparse, B
+                         + 589 + 189   # POSIX, IO::Socket
                          + 3 * ($] > 5.009)
                          + 14 * ($] >= 5.009003)
-                         + 780 + 588 );
+                         - 22);        # fudge
 
 require_ok("B::Concise");
 
 my %matchers = 
     ( constant => qr{ (?-x: is a constant sub, optimized to a \w+)
                      |(?-x: exists in stash, but has no START) }x,
-      XS       => qr{ (?-x: is XS code)
-                     |(?-x: exists in stash, but has no START) }x,
-      perl     => qr{ (?-x: (next|db)state)
-                     |(?-x: exists in stash, but has no START) }x,
-      noSTART  => qr/exists in stash, but has no START/,
+      XS       => qr/ is XS code/,
+      perl     => qr/ (next|db)state/,
+      noSTART  => qr/ exists in stash, but has no START/,
 );
 
 my $testpkgs = {
@@ -199,9 +200,26 @@ my $testpkgs = {
                      fmod floor dup2 dup difftime cuserid ctime
                      ctermid cosh constant close clock ceil
                      bootstrap atan asin asctime acos access abort
-                     _exit _POSIX_SAVED_IDS _POSIX_JOB_CONTROL
+                     _exit
                      /],
               },
+
+    IO::Socket => { dflt => 'constant',                # 157/188
+
+                   perl => [qw/ timeout socktype sockopt sockname
+                            socketpair socket sockdomain sockaddr_un
+                            sockaddr_in shutdown setsockopt send
+                            register_domain recv protocol peername
+                            new listen import getsockopt croak
+                            connected connect configure confess close
+                            carp bind atmark accept
+                            /],
+
+                   XS => [qw/ unpack_sockaddr_un unpack_sockaddr_in
+                          sockatmark sockaddr_family pack_sockaddr_un
+                          pack_sockaddr_in inet_ntoa inet_aton
+                          /],
+               },
 };
 
 ############

diff --git a/ext/B/t/optree_constants.t b/ext/B/t/optree_constants.t
index 1abe759..49243f5 100644 (file)
--- a/ext/B/t/optree_constants.t
+++ b/ext/B/t/optree_constants.t
@@ -19,7 +19,7 @@ BEGIN {
 use OptreeCheck;       # ALSO DOES @ARGV HANDLING !!!!!!
 use Config;
 
-my $tests = 18;
+my $tests = 23;
 plan tests => $tests;
 SKIP: {
 skip "no perlio in this build", $tests unless $Config::Config{useperlio};
@@ -34,6 +34,9 @@ use constant {                # see also t/op/gv.t line 282
     myglob => \*STDIN,
     myaref => [ 1,2,3 ],
     myhref => { a => 1 },
+    myundef => undef,
+    mysub => \&ok,
+    mysub => \&nosuch,
 };
 
 use constant WEEKDAYS
@@ -86,45 +89,72 @@ EONT_EONT
 
 checkOptree ( name     => 'myrex() as coderef',
              code      => \&myrex,
-             todo      => '- currently renders as XS code',
              noanchors => 1,
              expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
- is XS code
+ is a constant sub, optimized to a RV
 EOT_EOT
- is XS code
+ is a constant sub, optimized to a RV
 EONT_EONT
 
 
 checkOptree ( name     => 'myglob() as coderef',
              code      => \&myglob,
-             todo      => '- currently renders as XS code',
              noanchors => 1,
              expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
- is XS code
+ is a constant sub, optimized to a RV
 EOT_EOT
- is XS code
+ is a constant sub, optimized to a RV
 EONT_EONT
 
 
 checkOptree ( name     => 'myaref() as coderef',
              code      => \&myaref,
-             todo      => '- currently renders as XS code',
              noanchors => 1,
              expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
- is XS code
+ is a constant sub, optimized to a RV
 EOT_EOT
- is XS code
+ is a constant sub, optimized to a RV
 EONT_EONT
 
 
 checkOptree ( name     => 'myhref() as coderef',
              code      => \&myhref,
-             todo      => '- currently renders as XS code',
              noanchors => 1,
              expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
- is XS code
+ is a constant sub, optimized to a RV
 EOT_EOT
- is XS code
+ is a constant sub, optimized to a RV
+EONT_EONT
+
+
+checkOptree ( name     => 'myundef() as coderef',
+             code      => \&myundef,
+             noanchors => 1,
+             expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+ is a constant sub, optimized to a NULL
+EOT_EOT
+ is a constant sub, optimized to a NULL
+EONT_EONT
+
+
+checkOptree ( name     => 'mysub() as coderef',
+             code      => \&mysub,
+             noanchors => 1,
+             expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+ is a constant sub, optimized to a RV
+EOT_EOT
+ is a constant sub, optimized to a RV
+EONT_EONT
+
+
+checkOptree ( name     => 'myunsub() as coderef',
+             todo      => '- may prove only that sub is unformed',
+             code      => \&myunsub,
+             noanchors => 1,
+             expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+ has no START
+EOT_EOT
+ has no START
 EONT_EONT
 
 
@@ -245,6 +275,37 @@ EOT_EOT
 EONT_EONT
 
 
+checkOptree ( name     => 'call myundef',
+             code      => 'myundef',
+             noanchors => 1,
+             expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 3  <1> leavesub[1 ref] K/REFC,1 ->(end)
+# -     <@> lineseq KP ->3
+# 1        <;> nextstate(main 771 (eval 35):1) v ->2
+# 2        <$> const[NULL ] s ->3
+EOT_EOT
+# 3  <1> leavesub[1 ref] K/REFC,1 ->(end)
+# -     <@> lineseq KP ->3
+# 1        <;> nextstate(main 771 (eval 35):1) v ->2
+# 2        <$> const(NULL ) s ->3
+EONT_EONT
+
+
+checkOptree ( name     => 'call mysub',
+             code      => 'mysub',
+             noanchors => 1,
+             expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 3  <1> leavesub[1 ref] K/REFC,1 ->(end)
+# -     <@> lineseq KP ->3
+# 1        <;> nextstate(main 771 (eval 35):1) v ->2
+# 2        <$> const[RV \\] s ->3
+EOT_EOT
+# 3  <1> leavesub[1 ref] K/REFC,1 ->(end)
+# -     <@> lineseq KP ->3
+# 1        <;> nextstate(main 771 (eval 35):1) v ->2
+# 2        <$> const(RV \\) s ->3
+EONT_EONT
+
 ##################
 
 # test constant sub defined w/o 'use constant'
@@ -259,7 +320,7 @@ EOT_EOT
 EONT_EONT
 
 
-checkOptree ( name     => 'constant subs returning lists are not optimized',
+checkOptree ( name     => 'constant sub returning list',
              code      => \&WEEKDAYS,
              noanchors => 1,
              expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
@@ -280,7 +341,7 @@ sub printem {
        , myint, mystr, myfl, pi;
 }
 
-checkOptree ( name     => 'call em all in a print statement',
+checkOptree ( name     => 'call many in a print statement',
              code      => \&printem,
              expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 # 9  <1> leavesub[1 ref] K/REFC,1 ->(end)