summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPaul "LeoNerd" Evans <leonerd@leonerd.org.uk>2021-12-02 13:06:27 +0000
committerPaul Evans <leonerd@leonerd.org.uk>2021-12-03 10:59:24 +0000
commit1c57e39668d648fff43de7f8971c1bf9f23debfc (patch)
tree28c64613317397e289d839617269e7a1cbf4cd8c
parente728f790bcefcaf1d8b42e2f7ee16a9125f0af22 (diff)
downloadperl-1c57e39668d648fff43de7f8971c1bf9f23debfc.tar.gz
Improvements to OP_ISBOOL
* Apply OA_RETSCALAR, OA_TARGLEX and OA_FOLDCONST flags * Handle both 'get' and 'set' magic
-rw-r--r--builtin.c4
-rw-r--r--lib/B/Op_private.pm4
-rw-r--r--lib/builtin.t17
-rw-r--r--opcode.h10
-rw-r--r--pp.c6
-rw-r--r--regen/opcodes2
-rw-r--r--t/perf/opcount.t12
7 files changed, 43 insertions, 12 deletions
diff --git a/builtin.c b/builtin.c
index 5ea6e773f5..8919628e05 100644
--- a/builtin.c
+++ b/builtin.c
@@ -121,7 +121,7 @@ static OP *ck_builtin_func1(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
(void)op_sibling_splice(parent, pushop, 1, NULL);
- U8 flags = entersubop->op_flags;
+ U8 wantflags = entersubop->op_flags & OPf_WANT;
op_free(entersubop);
@@ -132,7 +132,7 @@ static OP *ck_builtin_func1(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
DIE(aTHX_ "panic: unhandled ckval value %" IVdf " for ck_builtin_func1()", builtin->ckval);
}
- return newUNOP(opcode, flags, argop);
+ return newUNOP(opcode, wantflags, argop);
}
static const char builtin_not_recognised[] = "'%" SVf "' is not recognised as a builtin function";
diff --git a/lib/B/Op_private.pm b/lib/B/Op_private.pm
index 2269bd52e4..be96920b6f 100644
--- a/lib/B/Op_private.pm
+++ b/lib/B/Op_private.pm
@@ -149,7 +149,7 @@ $bits{$_}{6} = 'OPpPAD_STATE' for qw(lvavref lvref padav padhv padsv pushmark re
$bits{$_}{7} = 'OPpPV_IS_UTF8' for qw(dump goto last next redo);
$bits{$_}{6} = 'OPpREFCOUNTED' for qw(leave leaveeval leavesub leavesublv leavewrite);
$bits{$_}{2} = 'OPpSLICEWARNING' for qw(aslice hslice padav padhv rv2av rv2hv);
-$bits{$_}{4} = 'OPpTARGET_MY' for qw(abs add atan2 chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int kill left_shift length link log mkdir modulo multiconcat multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push rand rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subtract symlink system time unlink unshift utime wait waitpid);
+$bits{$_}{4} = 'OPpTARGET_MY' for qw(abs add atan2 chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int isbool kill left_shift length link log mkdir modulo multiconcat multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push rand rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subtract symlink system time unlink unshift utime wait waitpid);
$bits{$_}{0} = 'OPpTRANS_CAN_FORCE_UTF8' for qw(trans transr);
$bits{$_}{5} = 'OPpTRANS_COMPLEMENT' for qw(trans transr);
$bits{$_}{7} = 'OPpTRANS_DELETE' for qw(trans transr);
@@ -838,7 +838,7 @@ our %ops_using = (
OPpSORT_DESCEND => [qw(sort)],
OPpSPLIT_ASSIGN => [qw(split)],
OPpSUBSTR_REPL_FIRST => [qw(substr)],
- OPpTARGET_MY => [qw(abs add atan2 chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int kill left_shift length link log mkdir modulo multiconcat multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push rand rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subtract symlink system time unlink unshift utime wait waitpid)],
+ OPpTARGET_MY => [qw(abs add atan2 chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int isbool kill left_shift length link log mkdir modulo multiconcat multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push rand rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subtract symlink system time unlink unshift utime wait waitpid)],
OPpTRANS_CAN_FORCE_UTF8 => [qw(trans transr)],
OPpTRUEBOOL => [qw(grepwhile index length padav padhv pos ref rindex rv2av rv2hv subst)],
OPpUSEINT => [qw(bit_and bit_or bit_xor complement left_shift nbit_and nbit_or nbit_xor ncomplement right_shift sbit_and sbit_or sbit_xor)],
diff --git a/lib/builtin.t b/lib/builtin.t
index 003efd5ff2..3338799721 100644
--- a/lib/builtin.t
+++ b/lib/builtin.t
@@ -9,6 +9,13 @@ BEGIN {
use strict;
use warnings;
+package FetchStoreCounter {
+ sub new { my $class = shift; return bless [@_], $class }
+ sub TIESCALAR { return shift->new(@_) }
+ sub FETCH { ${shift->[0]}++ }
+ sub STORE { ${shift->[1]}++ }
+}
+
# booleans
{
use builtin qw( true false isbool );
@@ -30,6 +37,16 @@ use warnings;
ok(isbool(isbool(true)), 'isbool true is bool');
ok(isbool(isbool(123)), 'isbool false is bool');
+
+ # Invokes magic
+
+ tie my $tied, FetchStoreCounter => (\my $fetchcount, \my $storecount);
+
+ my $_dummy = isbool($tied);
+ is($fetchcount, 1, 'isbool() invokes FETCH magic');
+
+ $tied = isbool(false);
+ is($storecount, 1, 'isbool() TARG invokes STORE magic');
}
# imports are lexical; should not be visible here
diff --git a/opcode.h b/opcode.h
index d33b348611..2042c1eee5 100644
--- a/opcode.h
+++ b/opcode.h
@@ -2212,7 +2212,7 @@ EXTCONST U32 PL_opargs[] = {
0x00000400, /* poptry */
0x00000300, /* catch */
0x00000300, /* pushdefer */
- 0x00000100, /* isbool */
+ 0x0000011e, /* isbool */
};
#endif
@@ -2883,7 +2883,7 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = {
-1, /* poptry */
0, /* catch */
0, /* pushdefer */
- 0, /* isbool */
+ 75, /* isbool */
};
@@ -2902,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, isbool */
+ 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 */
0x2fdc, 0x40d9, /* pushmark */
0x00bd, /* wantarray, runcv */
0x0438, 0x1a50, 0x418c, 0x3d28, 0x3505, /* const */
@@ -2923,7 +2923,7 @@ EXTCONST U16 PL_op_private_bitdefs[] = {
0x117c, 0x21b8, 0x09b4, 0x3fec, 0x2548, 0x4764, 0x07c1, /* trans, transr */
0x0fbc, 0x04d8, 0x0067, /* sassign */
0x0c78, 0x0b74, 0x0a70, 0x30cc, 0x05a8, 0x0067, /* aassign */
- 0x4530, 0x0003, /* chomp, schomp, scomplement, sin, cos, exp, log, sqrt, int, hex, oct, abs, ord, chr, chroot, rmdir */
+ 0x4530, 0x0003, /* chomp, schomp, scomplement, sin, cos, exp, log, sqrt, int, hex, oct, abs, ord, chr, chroot, rmdir, isbool */
0x05b4, 0x30cc, 0x0003, /* pos */
0x4530, 0x0067, /* pow, multiply, i_multiply, divide, i_divide, modulo, i_modulo, add, i_add, subtract, i_subtract */
0x1538, 0x0067, /* repeat */
@@ -3387,7 +3387,7 @@ EXTCONST U8 PL_op_private_valid[] = {
/* POPTRY */ (0),
/* CATCH */ (OPpARG1_MASK),
/* PUSHDEFER */ (OPpARG1_MASK),
- /* ISBOOL */ (OPpARG1_MASK),
+ /* ISBOOL */ (OPpARG1_MASK|OPpTARGET_MY),
};
diff --git a/pp.c b/pp.c
index c4b84fe940..5901656d53 100644
--- a/pp.c
+++ b/pp.c
@@ -7215,9 +7215,13 @@ PP(pp_cmpchain_dup)
PP(pp_isbool)
{
dSP;
+ dTARGET;
SV *arg = POPs;
- PUSHs(boolSV(SvIsBOOL(arg)));
+ SvGETMAGIC(arg);
+
+ sv_setbool_mg(TARG, SvIsBOOL(arg));
+ PUSHs(TARG);
RETURN;
}
diff --git a/regen/opcodes b/regen/opcodes
index 7942865641..063a628e7a 100644
--- a/regen/opcodes
+++ b/regen/opcodes
@@ -584,4 +584,4 @@ poptry pop try ck_null @
catch catch {} block ck_null |
pushdefer push defer {} block ck_null |
-isbool boolean type test ck_null 1
+isbool boolean type test ck_null fsT1
diff --git a/t/perf/opcount.t b/t/perf/opcount.t
index 815be12e87..80e3973d7d 100644
--- a/t/perf/opcount.t
+++ b/t/perf/opcount.t
@@ -696,10 +696,20 @@ test_opcount(0, "builtin::true/false are replaced with constants",
});
test_opcount(0, "builtin::isbool is replaced with direct opcode",
- sub { my $x = 123; my $y = builtin::isbool($x); },
+ sub { my $x; my $y; $y = builtin::isbool($x); },
{
entersub => 0,
isbool => 1,
+ padsv => 3, # OA_TARGLEX applies so only 3, not 4
+ sassign => 0,
+ });
+
+test_opcount(0, "builtin::isbool gets constant-folded",
+ sub { builtin::isbool(123); },
+ {
+ entersub => 0,
+ isbool => 0,
+ const => 1,
});
done_testing();