diff --git a/doio.c b/doio.c index d4b5f4660734..2089c91b996e 100644 --- a/doio.c +++ b/doio.c @@ -2205,11 +2205,23 @@ Perl_do_print(pTHX_ SV *sv, PerlIO *fp) return TRUE; if (SvTYPE(sv) == SVt_IV && SvIOK(sv)) { assert(!SvGMAGICAL(sv)); - if (SvIsUV(sv)) - PerlIO_printf(fp, "%" UVuf, (UV)SvUVX(sv)); - else - PerlIO_printf(fp, "%" IVdf, (IV)SvIVX(sv)); - return !PerlIO_error(fp); + + /* Adapted from Perl_sv_2pv_flags */ + const U32 isUIOK = SvIsUV(sv); + /* The purpose of this union is to ensure that arr is aligned on + a 2 byte boundary, because that is what uiv_2buf() requires */ + union { + char arr[TYPE_CHARS(UV)]; + U16 dummy; + } buf; + char *ebuf, *ptr; + STRLEN len; + UV tempuv = SvUVX(sv); + ptr = uiv_2buf(buf.arr, SvIVX(sv), tempuv, isUIOK, &ebuf); + len = ebuf - ptr; + + bool happy = !(len && (PerlIO_write(fp,ptr,len) == 0)); + return happy && !PerlIO_error(fp); } else { STRLEN len; @@ -2222,7 +2234,6 @@ Perl_do_print(pTHX_ SV *sv, PerlIO *fp) * Safefree(free_me) will free it. This saves having to have extra * logic. */ void *free_me = NULL; - bool happy = TRUE; if (PerlIO_isutf8(fp)) { /* If the stream is utf8 ... */ if (!SvUTF8(sv)) { /* Convert to utf8 if necessary */ @@ -2253,10 +2264,9 @@ Perl_do_print(pTHX_ SV *sv, PerlIO *fp) * but only until the system hard limit/the filesystem limit, * at which we would get EPERM. Note that when using buffered * io the write failure can be delayed until the flush/close. --jhi */ - if (len && (PerlIO_write(fp,tmps,len) == 0)) - happy = FALSE; + bool happy = !(len && (PerlIO_write(fp,tmps,len) == 0)); Safefree(free_me); - return happy ? !PerlIO_error(fp) : FALSE; + return happy && !PerlIO_error(fp); } } diff --git a/embed.fnc b/embed.fnc index fbb3ed84f0ca..7f5bba261559 100644 --- a/embed.fnc +++ b/embed.fnc @@ -3644,6 +3644,11 @@ EXop |bool |try_amagic_bin |int method \ |int flags EXop |bool |try_amagic_un |int method \ |int flags +ARTp |char * |uiv_2buf |NN char * const buf \ + |const IV iv \ + |UV uv \ + |const int is_uv \ + |NN char ** const peob Adp |SSize_t|unpackstring |NN const char *pat \ |NN const char *patend \ |NN const char *s \ @@ -5886,11 +5891,6 @@ ST |STRLEN |sv_pos_u2b_midway \ |const STRLEN uend i |void |sv_unglob |NN SV * const sv \ |U32 flags -RTi |char * |uiv_2buf |NN char * const buf \ - |const IV iv \ - |UV uv \ - |const int is_uv \ - |NN char ** const peob S |void |utf8_mg_len_cache_update \ |NN SV * const sv \ |NN MAGIC ** const mgp \ diff --git a/embed.h b/embed.h index d9e27472656c..be2f0418edc5 100644 --- a/embed.h +++ b/embed.h @@ -851,6 +851,7 @@ # define to_uni_lower(a,b,c) Perl_to_uni_lower(aTHX_ a,b,c) # define to_uni_title(a,b,c) Perl_to_uni_title(aTHX_ a,b,c) # define to_uni_upper(a,b,c) Perl_to_uni_upper(aTHX_ a,b,c) +# define uiv_2buf Perl_uiv_2buf # define unpackstring(a,b,c,d,e) Perl_unpackstring(aTHX_ a,b,c,d,e) # define unshare_hek(a) Perl_unshare_hek(aTHX_ a) # define unsharepvn(a,b,c) Perl_unsharepvn(aTHX_ a,b,c) @@ -2181,7 +2182,6 @@ # define sv_pos_u2b_forwards S_sv_pos_u2b_forwards # define sv_pos_u2b_midway S_sv_pos_u2b_midway # define sv_unglob(a,b) S_sv_unglob(aTHX_ a,b) -# define uiv_2buf S_uiv_2buf # define utf8_mg_len_cache_update(a,b,c) S_utf8_mg_len_cache_update(aTHX_ a,b,c) # define utf8_mg_pos_cache_update(a,b,c,d,e) S_utf8_mg_pos_cache_update(aTHX_ a,b,c,d,e) # define visit(a,b,c) S_visit(aTHX_ a,b,c) diff --git a/handy.h b/handy.h index e126500da07f..e2e5aa9e3e98 100644 --- a/handy.h +++ b/handy.h @@ -3103,7 +3103,6 @@ STMT_START { \ (x) ^= ((x) << 26); \ } STMT_END -#ifdef PERL_CORE /* Convenience macros for dealing with IV_MIN: In two's complement system, the absolute value of IV_MIN (i.e. -IV_MIN) cannot be represented in an IV. Thus we cannot use simple negation @@ -3160,8 +3159,6 @@ undefined behavior when C is equal to C>. # define NEGATE_2IV(uv) (ASSUME((uv) <= ABS_IV_MIN), \ (uv) < 8U ? -(IV)(uv) : -(IV)((uv) - 8U) - 8) -#endif /* PERL_CORE */ - #endif /* PERL_HANDY_H_ */ /* diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 2415c8204fe2..ac81a1affd22 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -89,6 +89,12 @@ There may well be none in a stable release. =item * +The stringification of integers by L and L, +when coming from an SVt_IV, is now more efficient. +[GH #22927] + +=item * + XXX =back diff --git a/proto.h b/proto.h index 3b125616efa0..6f23a9a1caef 100644 --- a/proto.h +++ b/proto.h @@ -5293,6 +5293,12 @@ PERL_CALLCONV bool Perl_try_amagic_un(pTHX_ int method, int flags); #define PERL_ARGS_ASSERT_TRY_AMAGIC_UN +PERL_CALLCONV char * +Perl_uiv_2buf(char * const buf, const IV iv, UV uv, const int is_uv, char ** const peob) + __attribute__warn_unused_result__; +#define PERL_ARGS_ASSERT_UIV_2BUF \ + assert(buf); assert(peob) + PERL_CALLCONV SSize_t Perl_unpackstring(pTHX_ const char *pat, const char *patend, const char *s, const char *strend, U32 flags); #define PERL_ARGS_ASSERT_UNPACKSTRING \ @@ -9071,13 +9077,7 @@ S_sv_unglob(pTHX_ SV * const sv, U32 flags); # define PERL_ARGS_ASSERT_SV_UNGLOB \ assert(sv) -PERL_STATIC_INLINE char * -S_uiv_2buf(char * const buf, const IV iv, UV uv, const int is_uv, char ** const peob) - __attribute__warn_unused_result__; -# define PERL_ARGS_ASSERT_UIV_2BUF \ - assert(buf); assert(peob) - -# endif /* !defined(PERL_NO_INLINE_FUNCTIONS) */ +# endif # if defined(USE_ITHREADS) STATIC SV * S_sv_dup_common(pTHX_ const SV * const ssv, CLONE_PARAMS * const param) diff --git a/sv.c b/sv.c index 3b1488b411f9..405e7bf6988c 100644 --- a/sv.c +++ b/sv.c @@ -2794,20 +2794,31 @@ static const union { '9', '8', '9', '9' }}; -/* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or - * UV as a string towards the end of buf, and return pointers to start and - * end of it. +/* uiv_2buf(): originally a private routine for use by sv_2pv_flags(), + * now in use by do_print() and part of the public API. It prints an + * IV or UV as a string towards the end of buf, and return pointers + * to the start and end of it. * * We assume that buf is at least TYPE_CHARS(UV) long. */ -PERL_STATIC_INLINE char * -S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob) +/* +=for apidoc uiv_2buf + +This function converts an IV or UV to its string representation. + +It is used internally by sv_2pv_flags() and do_print(). + +=cut +*/ + +char * +Perl_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob) { char *ptr = buf + TYPE_CHARS(UV); char * const ebuf = ptr; - int sign; - U16 *word_ptr, *word_table; + U16 *word_ptr; + U16 const *word_table; PERL_ARGS_ASSERT_UIV_2BUF; @@ -2816,16 +2827,17 @@ S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const pe /* we are going to read/write two bytes at a time */ word_ptr = (U16*)ptr; word_table = (U16*)int2str_table.arr; - - if (UNLIKELY(is_uv)) - sign = 0; - else if (iv >= 0) { - uv = iv; - sign = 0; - } else { - /* Using 0- here to silence bogus warning from MS VC */ - uv = (UV) (0 - (UV) iv); - sign = 1; + bool sign = false; + if (LIKELY(!is_uv)) { + if (iv >= 0) { + uv = iv; + } else { + /* This is NEGATE_2UV(iv), which can be found in handy.h. */ + /* sv_inline.h does not include handy.h because the latter + * would then get included twice into .c files. */ + uv = (ASSUME((iv) < 0), (UV)-((iv) + 1) + 1U); + sign = 1; + } } while (uv > 99) { diff --git a/t/perf/benchmarks b/t/perf/benchmarks index 9d0e00cf5024..bf88505a41be 100644 --- a/t/perf/benchmarks +++ b/t/perf/benchmarks @@ -1938,6 +1938,18 @@ code => '$p = pos($s);', }, + # func::print::iv_stringify should outperform func::print::iv_strings + 'func::print::iv_stringify' => { + desc => 'do_print stringification of SVt_IV integers', + setup => 'open(my $fh, ">", \$x) or die $!;', + code => 'print $fh 1,2,3,4,5,6,7,8,9,0;', + }, + 'func::print::iv_strings' => { + desc => 'do_print pre-stringified SVt_IV integers', + setup => 'open(my $fh, ">", \$x) or die $!;', + code => 'print $fh "1","2","3","4","5","6","7","8","9","0";', + }, + 'func::ref::notaref_bool' => { desc => 'ref($notaref) in boolean context', setup => 'my $r = "boo"', @@ -1970,8 +1982,6 @@ code => '$x = ref $r', }, - - 'func::sort::num' => { desc => 'plain numeric sort', setup => 'my (@a, @b); @a = reverse 1..10;', @@ -2034,7 +2044,6 @@ code => '@a = sort f @a', }, - 'func::split::vars' => { desc => 'split into two lexical vars', setup => 'my $s = "abc:def";',