Direct optree implementations of builtin:: functions

Turn builtin::true/false into OP_CONSTs

Add a dedicated OP_ISBOOL, make an efficient op version of builtin::isbool()

diff --git a/builtin.c b/builtin.c
index ce31448..5ea6e77 100644 (file)
--- a/builtin.c
+++ b/builtin.c
@@ -16,6 +16,13 @@
 
 #include "XSUB.h"
 
+struct BuiltinFuncDescriptor {
+    const char *name;
+    XSUBADDR_t xsub;
+    OP *(*checker)(pTHX_ OP *, GV *, SV *);
+    IV ckval;
+};
+
 XS(XS_builtin_true);
 XS(XS_builtin_true)
 {
@@ -34,22 +41,112 @@ XS(XS_builtin_false)
     XSRETURN_NO;
 }
 
-XS(XS_builtin_isbool);
-XS(XS_builtin_isbool)
+enum {
+    BUILTIN_CONST_FALSE,
+    BUILTIN_CONST_TRUE,
+};
+
+static OP *ck_builtin_const(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
+{
+    const struct BuiltinFuncDescriptor *builtin = NUM2PTR(const struct BuiltinFuncDescriptor *, SvUV(ckobj));
+
+    SV *prototype = newSVpvs("");
+    SAVEFREESV(prototype);
+
+    assert(entersubop->op_type == OP_ENTERSUB);
+
+    entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
+
+    SV *constval;
+    switch(builtin->ckval) {
+        case BUILTIN_CONST_FALSE: constval = &PL_sv_no; break;
+        case BUILTIN_CONST_TRUE:  constval = &PL_sv_yes; break;
+        default:
+            DIE(aTHX_ "panic: unrecognised builtin_const value %" IVdf, builtin->ckval);
+            break;
+    }
+
+    op_free(entersubop);
+
+    return newSVOP(OP_CONST, 0, constval);
+}
+
+enum {
+    BUILTIN_FUNC1_ISBOOL = 1,
+};
+
+XS(XS_builtin_func1);
+XS(XS_builtin_func1)
 {
     dXSARGS;
+    dXSI32;
+
     if(items != 1)
-        croak_xs_usage(cv, "sv");
+        croak_xs_usage(cv, "arg");
+
+    switch(ix) {
+        case BUILTIN_FUNC1_ISBOOL:
+            Perl_pp_isbool(aTHX);
+            break;
 
-    SV *sv = ST(0);
-    if(SvIsBOOL(sv))
-        XSRETURN_YES;
-    else
-        XSRETURN_NO;
+        default:
+            Perl_die(aTHX_ "panic: unhandled ix value %d for xs_builtin_func1()", ix);
+    }
+
+    XSRETURN(1);
+}
+
+static OP *ck_builtin_func1(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
+{
+    const struct BuiltinFuncDescriptor *builtin = NUM2PTR(const struct BuiltinFuncDescriptor *, SvUV(ckobj));
+
+    SV *prototype = newSVpvs("$");
+    SAVEFREESV(prototype);
+
+    assert(entersubop->op_type == OP_ENTERSUB);
+
+    entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
+
+    OP *parent = entersubop, *pushop, *argop;
+
+    pushop = cUNOPx(entersubop)->op_first;
+    if (!OpHAS_SIBLING(pushop)) {
+        pushop = cUNOPx(pushop)->op_first;
+    }
+
+    argop = OpSIBLING(pushop);
+
+    if (!argop || !OpHAS_SIBLING(argop) || OpHAS_SIBLING(OpSIBLING(argop)))
+        return entersubop;
+
+    (void)op_sibling_splice(parent, pushop, 1, NULL);
+
+    U8 flags = entersubop->op_flags;
+
+    op_free(entersubop);
+
+    OPCODE opcode;
+    switch(builtin->ckval) {
+        case BUILTIN_FUNC1_ISBOOL: opcode = OP_ISBOOL; break;
+        default:
+            DIE(aTHX_ "panic: unhandled ckval value %" IVdf " for ck_builtin_func1()", builtin->ckval);
+    }
+
+    return newUNOP(opcode, flags, argop);
 }
 
 static const char builtin_not_recognised[] = "'%" SVf "' is not recognised as a builtin function";
 
+static const struct BuiltinFuncDescriptor builtins[] = {
+    /* constants */
+    { "builtin::true",   &XS_builtin_true,   &ck_builtin_const, BUILTIN_CONST_TRUE  },
+    { "builtin::false",  &XS_builtin_false,  &ck_builtin_const, BUILTIN_CONST_FALSE },
+
+    /* unary functions */
+    { "builtin::isbool", &XS_builtin_func1, &ck_builtin_func1, BUILTIN_FUNC1_ISBOOL },
+    { 0 }
+};
+
 XS(XS_builtin_import);
 XS(XS_builtin_import)
 {
@@ -90,9 +187,23 @@ XS(XS_builtin_import)
 void
 Perl_boot_core_builtin(pTHX)
 {
-    newXS_flags("builtin::true",   &XS_builtin_true,   __FILE__, NULL, 0);
-    newXS_flags("builtin::false",  &XS_builtin_false,  __FILE__, NULL, 0);
-    newXS_flags("builtin::isbool", &XS_builtin_isbool, __FILE__, NULL, 0);
+    I32 i;
+    for(i = 0; builtins[i].name; i++) {
+        const struct BuiltinFuncDescriptor *builtin = &builtins[i];
+
+        const char *proto = NULL;
+        if(builtin->checker == &ck_builtin_const)
+            proto = "";
+        else if(builtin->checker == &ck_builtin_func1)
+            proto = "$";
+
+        CV *cv = newXS_flags(builtin->name, builtin->xsub, __FILE__, proto, 0);
+        XSANY.any_i32 = builtin->ckval;
+
+        if(builtin->checker) {
+            cv_set_call_checker_flags(cv, builtin->checker, newSVuv(PTR2UV(builtin)), 0);
+        }
+    }
 
     newXS_flags("builtin::import", &XS_builtin_import, __FILE__, NULL, 0);
 }

diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm
index ce8b5bf..ff6640c 100644 (file)
--- a/ext/Opcode/Opcode.pm
+++ b/ext/Opcode/Opcode.pm
@@ -6,7 +6,7 @@ use strict;
 
 our($VERSION, @ISA, @EXPORT_OK);
 
-$VERSION = "1.54";
+$VERSION = "1.55";
 
 use Carp;
 use Exporter 'import';
@@ -353,6 +353,8 @@ invert_opset function.
 
     cmpchain_and cmpchain_dup
 
+    isbool
+
     leaveeval -- needed for Safe to operate, is safe
                 without entereval
 

diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm
index 12f6a63..ec4a8a5 100644 (file)
--- a/lib/B/Deparse.pm
+++ b/lib/B/Deparse.pm
@@ -52,7 +52,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
         MDEREF_SHIFT
     );
 
-$VERSION = '1.59';
+$VERSION = '1.60';
 use strict;
 our $AUTOLOAD;
 use warnings ();
@@ -6603,6 +6603,16 @@ sub pp_pushdefer {
     return "defer {\n\t$body\n\b}\cK";
 }
 
+sub builtin1 {
+    my $self = shift;
+    my ($op, $cx, $name) = @_;
+    my $arg = $self->deparse($op->first);
+    # TODO: work out if lexical alias is present somehow...
+    return "builtin::$name($arg)";
+}
+
+sub pp_isbool { builtin1(@_, "isbool") }
+
 1;
 __END__
 

diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t
index ac3aaf8..138b31b 100644 (file)
--- a/lib/B/Deparse.t
+++ b/lib/B/Deparse.t
@@ -3198,3 +3198,6 @@ catch($var) {
 defer {
     $a = 123;
 }
+####
+# builtin:: functions
+my $x = builtin::isbool(undef);

diff --git a/lib/B/Op_private.pm b/lib/B/Op_private.pm
index be3975c..2269bd5 100644 (file)
--- a/lib/B/Op_private.pm
+++ b/lib/B/Op_private.pm
@@ -401,6 +401,7 @@ $bits{i_preinc}{0} = $bf[0];
 $bits{int}{0} = $bf[0];
 @{$bits{ioctl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
 @{$bits{isa}}{1,0} = ($bf[1], $bf[1]);
+$bits{isbool}{0} = $bf[0];
 @{$bits{join}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
 $bits{keys}{0} = $bf[0];
 @{$bits{kill}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);

diff --git a/opcode.h b/opcode.h
index 16f0bca..d33b348 100644 (file)
--- a/opcode.h
+++ b/opcode.h
@@ -554,6 +554,7 @@ EXTCONST char* const PL_op_name[] = {
        "poptry",
        "catch",
        "pushdefer",
+       "isbool",
         "freed",
 };
 #endif
@@ -967,6 +968,7 @@ EXTCONST char* const PL_op_desc[] = {
        "pop try",
        "catch {} block",
        "push defer {} block",
+       "boolean type test",
         "freed op",
 };
 #endif
@@ -1383,6 +1385,7 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */
        Perl_pp_poptry,
        Perl_pp_catch,
        Perl_pp_pushdefer,
+       Perl_pp_isbool,
 }
 #endif
 ;
@@ -1795,6 +1798,7 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */
        Perl_ck_null,           /* poptry */
        Perl_ck_null,           /* catch */
        Perl_ck_null,           /* pushdefer */
+       Perl_ck_null,           /* isbool */
 }
 #endif
 ;
@@ -2208,6 +2212,7 @@ EXTCONST U32 PL_opargs[] = {
        0x00000400,     /* poptry */
        0x00000300,     /* catch */
        0x00000300,     /* pushdefer */
+       0x00000100,     /* isbool */
 };
 #endif
 
@@ -2878,6 +2883,7 @@ EXTCONST I16  PL_op_private_bitdef_ix[] = {
       -1, /* poptry */
        0, /* catch */
        0, /* pushdefer */
+       0, /* isbool */
 
 };
 
@@ -2896,7 +2902,7 @@ EXTCONST I16  PL_op_private_bitdef_ix[] = {
  */
 
 EXTCONST U16  PL_op_private_bitdefs[] = {
-    0x0003, /* scalar, prototype, refgen, srefgen, readline, regcmaybe, regcreset, regcomp, substcont, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, ucfirst, lcfirst, uc, lc, quotemeta, aeach, avalues, each, pop, shift, grepstart, mapstart, mapwhile, range, and, or, dor, andassign, orassign, dorassign, argcheck, argdefelem, method, method_named, method_super, method_redir, method_redir_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, fc, anonconst, cmpchain_and, cmpchain_dup, entertrycatch, catch, pushdefer */
+    0x0003, /* scalar, prototype, refgen, srefgen, readline, regcmaybe, regcreset, regcomp, substcont, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, ucfirst, lcfirst, uc, lc, quotemeta, aeach, avalues, each, pop, shift, grepstart, mapstart, mapwhile, range, and, or, dor, andassign, orassign, dorassign, argcheck, argdefelem, method, method_named, method_super, method_redir, method_redir_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, fc, anonconst, cmpchain_and, cmpchain_dup, entertrycatch, catch, pushdefer, isbool */
     0x2fdc, 0x40d9, /* pushmark */
     0x00bd, /* wantarray, runcv */
     0x0438, 0x1a50, 0x418c, 0x3d28, 0x3505, /* const */
@@ -3381,6 +3387,7 @@ EXTCONST U8 PL_op_private_valid[] = {
     /* POPTRY     */ (0),
     /* CATCH      */ (OPpARG1_MASK),
     /* PUSHDEFER  */ (OPpARG1_MASK),
+    /* ISBOOL     */ (OPpARG1_MASK),
 
 };
 

diff --git a/opnames.h b/opnames.h
index a78baab..a8a46f2 100644 (file)
--- a/opnames.h
+++ b/opnames.h
@@ -419,10 +419,11 @@ typedef enum opcode {
        OP_POPTRY        = 402,
        OP_CATCH         = 403,
        OP_PUSHDEFER     = 404,
+       OP_ISBOOL        = 405,
        OP_max          
 } opcode;
 
-#define MAXO 405
+#define MAXO 406
 #define OP_FREED MAXO
 
 /* the OP_IS_* macros are optimized to a simple range check because

diff --git a/pp.c b/pp.c
index e37e3dd..c4b84fe 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -7212,6 +7212,15 @@ PP(pp_cmpchain_dup)
     RETURN;
 }
 
+PP(pp_isbool)
+{
+    dSP;
+    SV *arg = POPs;
+
+    PUSHs(boolSV(SvIsBOOL(arg)));
+    RETURN;
+}
+
 /*
  * ex: set ts=8 sts=4 sw=4 et:
  */

diff --git a/pp_proto.h b/pp_proto.h
index 5f0b450..1210c80 100644 (file)
--- a/pp_proto.h
+++ b/pp_proto.h
@@ -131,6 +131,7 @@ PERL_CALLCONV OP *Perl_pp_int(pTHX);
 PERL_CALLCONV OP *Perl_pp_introcv(pTHX);
 PERL_CALLCONV OP *Perl_pp_ioctl(pTHX);
 PERL_CALLCONV OP *Perl_pp_isa(pTHX);
+PERL_CALLCONV OP *Perl_pp_isbool(pTHX);
 PERL_CALLCONV OP *Perl_pp_iter(pTHX);
 PERL_CALLCONV OP *Perl_pp_join(pTHX);
 PERL_CALLCONV OP *Perl_pp_kvaslice(pTHX);

diff --git a/regen/opcodes b/regen/opcodes
index 0192f1c..7942865 100644 (file)
--- a/regen/opcodes
+++ b/regen/opcodes
@@ -583,3 +583,5 @@ leavetrycatch       try {block} exit        ck_null         @
 poptry         pop try                 ck_null         @
 catch          catch {} block          ck_null         |
 pushdefer      push defer {} block     ck_null         |
+
+isbool         boolean type test       ck_null         1

diff --git a/t/perf/opcount.t b/t/perf/opcount.t
index 0e13533..815be12 100644 (file)
--- a/t/perf/opcount.t
+++ b/t/perf/opcount.t
@@ -20,8 +20,6 @@ BEGIN {
 use warnings;
 use strict;
 
-plan 2584;
-
 use B ();
 
 
@@ -687,3 +685,21 @@ test_opcount(0, "multiconcat: local assign",
                         aelem         => 0,
                     });
 }
+
+# builtin:: function calls should be replaced with efficient op implementations
+
+test_opcount(0, "builtin::true/false are replaced with constants",
+                sub { my $x = builtin::true(); my $y = builtin::false() },
+                {
+                    entersub => 0,
+                    const    => 2,
+                });
+
+test_opcount(0, "builtin::isbool is replaced with direct opcode",
+                sub { my $x = 123; my $y = builtin::isbool($x); },
+                {
+                    entersub => 0,
+                    isbool   => 1,
+                });
+
+done_testing();