diff options
author | Paul "LeoNerd" Evans <leonerd@leonerd.org.uk> | 2021-12-02 13:06:27 +0000 |
---|---|---|
committer | Paul Evans <leonerd@leonerd.org.uk> | 2021-12-03 10:59:24 +0000 |
commit | 1c57e39668d648fff43de7f8971c1bf9f23debfc (patch) | |
tree | 28c64613317397e289d839617269e7a1cbf4cd8c | |
parent | e728f790bcefcaf1d8b42e2f7ee16a9125f0af22 (diff) | |
download | perl-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.c | 4 | ||||
-rw-r--r-- | lib/B/Op_private.pm | 4 | ||||
-rw-r--r-- | lib/builtin.t | 17 | ||||
-rw-r--r-- | opcode.h | 10 | ||||
-rw-r--r-- | pp.c | 6 | ||||
-rw-r--r-- | regen/opcodes | 2 | ||||
-rw-r--r-- | t/perf/opcount.t | 12 |
7 files changed, 43 insertions, 12 deletions
@@ -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 @@ -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), }; @@ -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(); |