From 17a8df707746ce70979d18c5b5f9e383c365bbff Mon Sep 17 00:00:00 2001 From: James Raspass Date: Sat, 22 Jan 2022 11:07:58 +0000 Subject: Add ceil & floor to builtin --- builtin.c | 10 ++++++++++ ext/Opcode/Opcode.pm | 5 +++-- lib/B/Deparse.pm | 6 ++++-- lib/B/Deparse.t | 2 ++ lib/B/Op_private.pm | 6 ++++-- lib/builtin.pm | 17 ++++++++++++++++- lib/builtin.t | 27 +++++++++++++++++++++++++++ opcode.h | 16 +++++++++++++++- opnames.h | 4 +++- pp.c | 16 ++++++++++++++++ pp_proto.h | 2 ++ regen/opcodes | 2 ++ t/perf/opcount.t | 15 +++++++++++++++ 13 files changed, 119 insertions(+), 9 deletions(-) diff --git a/builtin.c b/builtin.c index 5ef3a0bdfd..1e364f34a3 100644 --- a/builtin.c +++ b/builtin.c @@ -101,6 +101,14 @@ XS(XS_builtin_func1_scalar) Perl_pp_reftype(aTHX); break; + case OP_CEIL: + Perl_pp_ceil(aTHX); + break; + + case OP_FLOOR: + Perl_pp_floor(aTHX); + break; + default: Perl_die(aTHX_ "panic: unhandled opcode %d for xs_builtin_func1_scalar()", ix); } @@ -182,6 +190,8 @@ static const struct BuiltinFuncDescriptor builtins[] = { { "builtin::blessed", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_BLESSED }, { "builtin::refaddr", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFADDR }, { "builtin::reftype", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFTYPE }, + { "builtin::ceil", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_CEIL }, + { "builtin::floor", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_FLOOR }, { 0 } }; diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm index a2b5621641..377659d2f4 100644 --- a/ext/Opcode/Opcode.pm +++ b/ext/Opcode/Opcode.pm @@ -6,7 +6,7 @@ use strict; our($VERSION, @ISA, @EXPORT_OK); -$VERSION = "1.55"; +$VERSION = "1.56"; use Carp; use Exporter 'import'; @@ -449,6 +449,8 @@ These are a hotchpotch of opcodes still waiting to be considered custom -- where should this go + ceil floor + =item :base_math These ops are not included in :base_core because of the risk of them being @@ -616,4 +618,3 @@ Split out from Safe module version 1, named opcode tags and other changes added by Tim Bunce. =cut - diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm index 8570bb40d9..b01acda4c4 100644 --- a/lib/B/Deparse.pm +++ b/lib/B/Deparse.pm @@ -8,6 +8,7 @@ # but essentially none of his code remains. package B::Deparse; +use strict; use Carp; use B qw(class main_root main_start main_cv svref_2object opnumber perlstring OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST @@ -52,8 +53,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring MDEREF_SHIFT ); -$VERSION = '1.61'; -use strict; +our $VERSION = '1.62'; our $AUTOLOAD; use warnings (); require feature; @@ -6638,6 +6638,8 @@ sub pp_unweaken { builtin1(@_, "unweaken"); } sub pp_blessed { builtin1(@_, "blessed"); } sub pp_refaddr { $_[0]->maybe_targmy(@_[1,2], \&builtin1, "refaddr"); } sub pp_reftype { $_[0]->maybe_targmy(@_[1,2], \&builtin1, "reftype"); } +sub pp_ceil { $_[0]->maybe_targmy(@_[1,2], \&builtin1, "ceil"); } +sub pp_floor { $_[0]->maybe_targmy(@_[1,2], \&builtin1, "floor"); } 1; __END__ diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t index c9c519b2d0..4587d45c41 100644 --- a/lib/B/Deparse.t +++ b/lib/B/Deparse.t @@ -3218,3 +3218,5 @@ builtin::unweaken($x); $x = builtin::blessed(undef); $x = builtin::refaddr(undef); $x = builtin::reftype(undef); +$x = builtin::ceil($x); +$x = builtin::floor($x); diff --git a/lib/B/Op_private.pm b/lib/B/Op_private.pm index d1c5829970..9b60b66918 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 isbool isweak kill left_shift length link log mkdir modulo multiconcat multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push rand refaddr reftype 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 ceil chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock floor getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int isbool isweak kill left_shift length link log mkdir modulo multiconcat multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push rand refaddr reftype 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); @@ -275,6 +275,7 @@ $bits{backtick}{0} = $bf[0]; $bits{blessed}{0} = $bf[0]; @{$bits{caller}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{catch}{0} = $bf[0]; +$bits{ceil}{0} = $bf[0]; @{$bits{chdir}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); @{$bits{chmod}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{chomp}{0} = $bf[0]; @@ -323,6 +324,7 @@ $bits{fc}{0} = $bf[0]; @{$bits{fileno}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{flip}{0} = $bf[0]; @{$bits{flock}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{floor}{0} = $bf[0]; $bits{flop}{0} = $bf[0]; @{$bits{formline}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{ftatime}{0} = $bf[0]; @@ -847,7 +849,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 isbool isweak kill left_shift length link log mkdir modulo multiconcat multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push rand refaddr reftype 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 ceil chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock floor getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int isbool isweak kill left_shift length link log mkdir modulo multiconcat multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push rand refaddr reftype 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(blessed 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.pm b/lib/builtin.pm index 326d200d36..f38d8a99fe 100644 --- a/lib/builtin.pm +++ b/lib/builtin.pm @@ -1,4 +1,4 @@ -package builtin 0.001; +package builtin 0.002; use strict; use warnings; @@ -20,6 +20,7 @@ builtin - Perl pragma to import built-in utility functions true false isbool weaken unweaken isweak blessed refaddr reftype + ceil floor ); =head1 DESCRIPTION @@ -147,6 +148,20 @@ Returns the basic container type of the referent of a reference, or C for a non-reference. This is returned as a string in all-capitals, such as C for array references, or C for hash references. +=head2 ceil + + $num = ceil($num); + +Returns the smallest integer value greater than or equal to the given +numerical argument. + +=head2 floor + + $num = floor($num); + +Returns the largest integer value less than or equal to the given numerical +argument. + =head1 SEE ALSO L, L, L diff --git a/lib/builtin.t b/lib/builtin.t index e35e8ab393..75a93cd27f 100644 --- a/lib/builtin.t +++ b/lib/builtin.t @@ -93,6 +93,33 @@ package FetchStoreCounter { is(blessed(bless [], "0") ? "YES" : "NO", "NO", 'blessed in boolean context handles "0" cornercase'); } +# ceil, floor +{ + use builtin qw( ceil floor ); + + cmp_ok(ceil(1.5), '==', 2, 'ceil(1.5) == 2'); + cmp_ok(floor(1.5), '==', 1, 'floor(1.5) == 1'); + + # Invokes magic + + tie my $tied, FetchStoreCounter => (\my $fetchcount, \my $storecount); + + my $_dummy = ceil($tied); + is($fetchcount, 1, 'ceil() invokes FETCH magic'); + + $tied = ceil(1.1); + is($storecount, 1, 'ceil() TARG invokes STORE magic'); + + $fetchcount = $storecount = 0; + tie $tied, FetchStoreCounter => (\$fetchcount, \$storecount); + + $_dummy = floor($tied); + is($fetchcount, 1, 'floor() invokes FETCH magic'); + + $tied = floor(1.1); + is($storecount, 1, 'floor() TARG invokes STORE magic'); +} + # imports are lexical; should not be visible here { my $ok = eval 'true()'; my $e = $@; diff --git a/opcode.h b/opcode.h index 3a08dfae22..decd14710c 100644 --- a/opcode.h +++ b/opcode.h @@ -561,6 +561,8 @@ EXTCONST char* const PL_op_name[] = { "blessed", "refaddr", "reftype", + "ceil", + "floor", "freed", }; #endif @@ -981,6 +983,8 @@ EXTCONST char* const PL_op_desc[] = { "blessed", "refaddr", "reftype", + "ceil", + "floor", "freed op", }; #endif @@ -1404,6 +1408,8 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */ Perl_pp_blessed, Perl_pp_refaddr, Perl_pp_reftype, + Perl_pp_ceil, + Perl_pp_floor, } #endif ; @@ -1823,6 +1829,8 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */ Perl_ck_null, /* blessed */ Perl_ck_null, /* refaddr */ Perl_ck_null, /* reftype */ + Perl_ck_null, /* ceil */ + Perl_ck_null, /* floor */ } #endif ; @@ -2243,6 +2251,8 @@ EXTCONST U32 PL_opargs[] = { 0x00000106, /* blessed */ 0x0000011e, /* refaddr */ 0x0000011e, /* reftype */ + 0x0000011e, /* ceil */ + 0x0000011e, /* floor */ }; #endif @@ -2922,6 +2932,8 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { 49, /* blessed */ 75, /* refaddr */ 75, /* reftype */ + 75, /* ceil */ + 75, /* floor */ }; @@ -2961,7 +2973,7 @@ EXTCONST U16 PL_op_private_bitdefs[] = { 0x117c, 0x22b8, 0x09b4, 0x40ec, 0x2648, 0x4864, 0x07c1, /* trans, transr */ 0x0fbc, 0x04d8, 0x0067, /* sassign */ 0x0c78, 0x0b74, 0x0a70, 0x31cc, 0x05a8, 0x0067, /* aassign */ - 0x4630, 0x0003, /* chomp, schomp, scomplement, sin, cos, exp, log, sqrt, int, hex, oct, abs, ord, chr, chroot, rmdir, isbool, isweak, refaddr, reftype */ + 0x4630, 0x0003, /* chomp, schomp, scomplement, sin, cos, exp, log, sqrt, int, hex, oct, abs, ord, chr, chroot, rmdir, isbool, isweak, refaddr, reftype, ceil, floor */ 0x05b4, 0x31cc, 0x0003, /* pos */ 0x4630, 0x0067, /* pow, multiply, i_multiply, divide, i_divide, modulo, i_modulo, add, i_add, subtract, i_subtract */ 0x1538, 0x0067, /* repeat */ @@ -3433,6 +3445,8 @@ EXTCONST U8 PL_op_private_valid[] = { /* BLESSED */ (OPpARG1_MASK|OPpMAYBE_TRUEBOOL|OPpTRUEBOOL), /* REFADDR */ (OPpARG1_MASK|OPpTARGET_MY), /* REFTYPE */ (OPpARG1_MASK|OPpTARGET_MY), + /* CEIL */ (OPpARG1_MASK|OPpTARGET_MY), + /* FLOOR */ (OPpARG1_MASK|OPpTARGET_MY), }; diff --git a/opnames.h b/opnames.h index cfad87aaf7..f03ba7f6ba 100644 --- a/opnames.h +++ b/opnames.h @@ -426,10 +426,12 @@ typedef enum opcode { OP_BLESSED = 409, OP_REFADDR = 410, OP_REFTYPE = 411, + OP_CEIL = 412, + OP_FLOOR = 413, OP_max } opcode; -#define MAXO 412 +#define MAXO 414 #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 643a8758b7..b53fd87968 100644 --- a/pp.c +++ b/pp.c @@ -7326,6 +7326,22 @@ PP(pp_reftype) RETURN; } +PP(pp_ceil) +{ + dSP; + dTARGET; + PUSHn(Perl_ceil(POPn)); + RETURN; +} + +PP(pp_floor) +{ + dSP; + dTARGET; + PUSHn(Perl_floor(POPn)); + RETURN; +} + /* * ex: set ts=8 sts=4 sw=4 et: */ diff --git a/pp_proto.h b/pp_proto.h index 815fedc338..ed80604737 100644 --- a/pp_proto.h +++ b/pp_proto.h @@ -36,6 +36,7 @@ PERL_CALLCONV OP *Perl_pp_blessed(pTHX); PERL_CALLCONV OP *Perl_pp_break(pTHX); PERL_CALLCONV OP *Perl_pp_caller(pTHX); PERL_CALLCONV OP *Perl_pp_catch(pTHX); +PERL_CALLCONV OP *Perl_pp_ceil(pTHX); PERL_CALLCONV OP *Perl_pp_chdir(pTHX); PERL_CALLCONV OP *Perl_pp_chop(pTHX); PERL_CALLCONV OP *Perl_pp_chown(pTHX); @@ -80,6 +81,7 @@ PERL_CALLCONV OP *Perl_pp_fc(pTHX); PERL_CALLCONV OP *Perl_pp_fileno(pTHX); PERL_CALLCONV OP *Perl_pp_flip(pTHX); PERL_CALLCONV OP *Perl_pp_flock(pTHX); +PERL_CALLCONV OP *Perl_pp_floor(pTHX); PERL_CALLCONV OP *Perl_pp_flop(pTHX); PERL_CALLCONV OP *Perl_pp_fork(pTHX); PERL_CALLCONV OP *Perl_pp_formline(pTHX); diff --git a/regen/opcodes b/regen/opcodes index ade3d70acc..45391a2c98 100644 --- a/regen/opcodes +++ b/regen/opcodes @@ -591,3 +591,5 @@ unweaken reference unweaken ck_null 1 blessed blessed ck_null fs1 refaddr refaddr ck_null fsT1 reftype reftype ck_null fsT1 +ceil ceil ck_null fsT1 +floor floor ck_null fsT1 diff --git a/t/perf/opcount.t b/t/perf/opcount.t index 372c47f3d6..3351f50f07 100644 --- a/t/perf/opcount.t +++ b/t/perf/opcount.t @@ -766,4 +766,19 @@ test_opcount(0, "builtin::reftype is replaced with direct opcode", reftype => 1, }); +my $one_point_five = 1.5; # Prevent const-folding. +test_opcount(0, "builtin::ceil is replaced with direct opcode", + sub { builtin::ceil($one_point_five); }, + { + entersub => 0, + ceil => 1, + }); + +test_opcount(0, "builtin::floor is replaced with direct opcode", + sub { builtin::floor($one_point_five); }, + { + entersub => 0, + floor => 1, + }); + done_testing(); -- cgit v1.2.1