add sv_set_undef() API function

This function is equivalent to sv_setsv(sv, &PL_sv_undef), but more
efficient.

Also change the obvious places in the core to use the new idiom.

diff --git a/embed.fnc b/embed.fnc
index 4743aed..e03c4d2 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2709,6 +2709,7 @@ sRM       |U8*    |swash_scan_list_line|NN U8* l|NN U8* const lend|NN UV* min \
 AiMn   |void   |append_utf8_from_native_byte|const U8 byte|NN U8** dest
 #endif
 
 AiMn   |void   |append_utf8_from_native_byte|const U8 byte|NN U8** dest
 #endif
 

+Apd    |void   |sv_set_undef   |NN SV *sv

 Apd    |void   |sv_setsv_flags |NN SV *dstr|NULLOK SV *sstr|const I32 flags
 Apd    |void   |sv_catpvn_flags|NN SV *const dstr|NN const char *sstr|const STRLEN len \
                                |const I32 flags
 Apd    |void   |sv_setsv_flags |NN SV *dstr|NULLOK SV *sstr|const I32 flags
 Apd    |void   |sv_catpvn_flags|NN SV *const dstr|NN const char *sstr|const STRLEN len \
                                |const I32 flags

diff --git a/embed.h b/embed.h
index d54ed6c..6061d55 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -664,6 +664,7 @@
 #define sv_report_used()       Perl_sv_report_used(aTHX)
 #define sv_reset(a,b)          Perl_sv_reset(aTHX_ a,b)
 #define sv_rvweaken(a)         Perl_sv_rvweaken(aTHX_ a)
 #define sv_report_used()       Perl_sv_report_used(aTHX)
 #define sv_reset(a,b)          Perl_sv_reset(aTHX_ a,b)
 #define sv_rvweaken(a)         Perl_sv_rvweaken(aTHX_ a)

+#define sv_set_undef(a)                Perl_sv_set_undef(aTHX_ a)

 #define sv_setiv(a,b)          Perl_sv_setiv(aTHX_ a,b)
 #define sv_setiv_mg(a,b)       Perl_sv_setiv_mg(aTHX_ a,b)
 #define sv_setnv(a,b)          Perl_sv_setnv(aTHX_ a,b)
 #define sv_setiv(a,b)          Perl_sv_setiv(aTHX_ a,b)
 #define sv_setiv_mg(a,b)       Perl_sv_setiv_mg(aTHX_ a,b)
 #define sv_setnv(a,b)          Perl_sv_setnv(aTHX_ a,b)

diff --git a/mg.c b/mg.c
index b7ce69d..cbabcc6 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -725,7 +725,7 @@ Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
     PERL_ARGS_ASSERT_EMULATE_COP_IO;
 
     if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
     PERL_ARGS_ASSERT_EMULATE_COP_IO;
 
     if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))

-       sv_setsv(sv, &PL_sv_undef);
+       sv_set_undef(sv);

     else {
         SvPVCLEAR(sv);
        SvUTF8_off(sv);
     else {
         SvPVCLEAR(sv);
        SvUTF8_off(sv);


@@ -800,9 +800,9 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
           do_numbuf_fetch:
             CALLREG_NUMBUF_FETCH(rx,paren,sv);
         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
           do_numbuf_fetch:
             CALLREG_NUMBUF_FETCH(rx,paren,sv);

-        } else {
-            sv_setsv(sv,&PL_sv_undef);

         }
         }

+        else
+            goto set_undef;

         return 0;
     }
 
         return 0;
     }
 


@@ -810,7 +810,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
     switch (*mg->mg_ptr) {
     case '\001':               /* ^A */
        if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget);
     switch (*mg->mg_ptr) {
     case '\001':               /* ^A */
        if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget);

-       else sv_setsv(sv, &PL_sv_undef);
+       else
+            sv_set_undef(sv);

        if (SvTAINTED(PL_bodytarget))
            SvTAINTED_on(sv);
        break;
        if (SvTAINTED(PL_bodytarget))
            SvTAINTED_on(sv);
        break;


@@ -994,8 +995,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
                sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
            }
            else if (PL_compiling.cop_warnings == pWARN_STD) {
                sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
            }
            else if (PL_compiling.cop_warnings == pWARN_STD) {

-               sv_setsv(sv, &PL_sv_undef);
-               break;
+                goto set_undef;

            }
             else if (PL_compiling.cop_warnings == pWARN_ALL) {
                /* Get the bit mask for $warnings::Bits{all}, because
            }
             else if (PL_compiling.cop_warnings == pWARN_ALL) {
                /* Get the bit mask for $warnings::Bits{all}, because


@@ -1024,16 +1024,14 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
            if (paren)
                 goto do_numbuf_fetch;
        }
            if (paren)
                 goto do_numbuf_fetch;
        }

-       sv_setsv(sv,&PL_sv_undef);
-       break;
+        goto set_undef;

     case '\016':               /* ^N */
        if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
            paren = RX_LASTCLOSEPAREN(rx);
            if (paren)
                 goto do_numbuf_fetch;
        }
     case '\016':               /* ^N */
        if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
            paren = RX_LASTCLOSEPAREN(rx);
            if (paren)
                 goto do_numbuf_fetch;
        }

-       sv_setsv(sv,&PL_sv_undef);
-       break;
+        goto set_undef;

     case '.':
        if (GvIO(PL_last_in_gv)) {
            sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
     case '.':
        if (GvIO(PL_last_in_gv)) {
            sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));


@@ -1092,7 +1090,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
        if (PL_ors_sv)
            sv_copypv(sv, PL_ors_sv);
        else
        if (PL_ors_sv)
            sv_copypv(sv, PL_ors_sv);
        else

-           sv_setsv(sv, &PL_sv_undef);
+            goto set_undef;

        break;
     case '$': /* $$ */
        {
        break;
     case '$': /* $$ */
        {


@@ -1138,6 +1136,10 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
        break;
     }
     return 0;
        break;
     }
     return 0;

+
+  set_undef:
+    sv_set_undef(sv);
+    return 0;

 }
 
 int
 }
 
 int


@@ -1341,7 +1343,7 @@ Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
            if(sigstate == (Sighandler_t) SIG_IGN)
                sv_setpvs(sv,"IGNORE");
            else
            if(sigstate == (Sighandler_t) SIG_IGN)
                sv_setpvs(sv,"IGNORE");
            else

-               sv_setsv(sv,&PL_sv_undef);
+                sv_set_undef(sv);

            PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
            SvTEMP_off(sv);
        }
            PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
            SvTEMP_off(sv);
        }


@@ -2189,7 +2191,7 @@ Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
            negrem ? -(IV)rem  : (IV)rem,  !negrem, &offs, &rem
     )) {
        Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
            negrem ? -(IV)rem  : (IV)rem,  !negrem, &offs, &rem
     )) {
        Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");

-       sv_setsv_nomg(sv, &PL_sv_undef);
+        sv_set_undef(sv);

        return 0;
     }
 
        return 0;
     }
 

diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 9719550..070fd4a 100644 (file)
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -323,7 +323,8 @@ well.
 
 =item *
 
 
 =item *
 

-XXX
+A new API function, C<sv_set_undef(sv)>, has been added. This is
+equivalent to C<sv_setsv(sv, &PL_sv_undef)>, but is more efficient.

 
 =back
 
 
 =back
 

diff --git a/pp.c b/pp.c
index ce589a0..d406ee1 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -3249,7 +3249,7 @@ PP(pp_length)
        }
     } else {
        if (!SvPADTMP(TARG)) {
        }
     } else {
        if (!SvPADTMP(TARG)) {

-           sv_setsv_nomg(TARG, &PL_sv_undef);
+            sv_set_undef(TARG);

        } else { /* TARG is on stack at this point and is overwriten by SETs.
                    This branch is the odd one out, so put TARG by default on
                    stack earlier to let local SP go out of liveness sooner */
        } else { /* TARG is on stack at this point and is overwriten by SETs.
                    This branch is the odd one out, so put TARG by default on
                    stack earlier to let local SP go out of liveness sooner */

diff --git a/pp_hot.c b/pp_hot.c
index c614d29..dd2c611 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1776,7 +1776,7 @@ PP(pp_aassign)
 
        default:
            if (!SvIMMORTAL(lsv)) {
 
        default:
            if (!SvIMMORTAL(lsv)) {

-                sv_setsv(lsv, &PL_sv_undef);
+                sv_set_undef(lsv);

                 SvSETMAGIC(lsv);
                 *relem++ = lsv;
             }
                 SvSETMAGIC(lsv);
                 *relem++ = lsv;
             }

diff --git a/proto.h b/proto.h
index 5ff6bfe..b760924 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -3224,6 +3224,9 @@ PERL_CALLCONV void        Perl_sv_resetpvn(pTHX_ const char* s, STRLEN len, HV *const s
 PERL_CALLCONV SV*      Perl_sv_rvweaken(pTHX_ SV *const sv);
 #define PERL_ARGS_ASSERT_SV_RVWEAKEN   \
        assert(sv)
 PERL_CALLCONV SV*      Perl_sv_rvweaken(pTHX_ SV *const sv);
 #define PERL_ARGS_ASSERT_SV_RVWEAKEN   \
        assert(sv)

+PERL_CALLCONV void     Perl_sv_set_undef(pTHX_ SV *sv);
+#define PERL_ARGS_ASSERT_SV_SET_UNDEF  \
+       assert(sv)

 PERL_CALLCONV void     Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek);
 #define PERL_ARGS_ASSERT_SV_SETHEK     \
        assert(sv)
 PERL_CALLCONV void     Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek);
 #define PERL_ARGS_ASSERT_SV_SETHEK     \
        assert(sv)

diff --git a/regcomp.c b/regcomp.c
index bb4b502..095b13f 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -8139,7 +8139,7 @@ Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
         }
     } else {
       ret_undef:
         }
     } else {
       ret_undef:

-        sv_setsv(sv,&PL_sv_undef);
+        sv_set_undef(sv);

         return;
     }
 }
         return;
     }
 }

diff --git a/sv.c b/sv.c
index f3c057b..6a17049 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -4782,6 +4782,64 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
        SvTAINT(dstr);
 }
 
        SvTAINT(dstr);
 }
 

+
+/*
+=for apidoc sv_set_undef
+
+Equivalent to C<sv_setsv(sv, &PL_sv_undef)>, but more efficient.
+Doesn't handle set magic.
+
+The perl equivalent is C<$sv = undef;>. Note that it doesn't free any string
+buffer, unlike C<undef $sv>.
+
+Introduced in perl 5.26.0.
+
+=cut
+*/
+
+void
+Perl_sv_set_undef(pTHX_ SV *sv)
+{
+    U32 type = SvTYPE(sv);
+
+    PERL_ARGS_ASSERT_SV_SET_UNDEF;
+
+    /* shortcut, NULL, IV, RV */
+
+    if (type <= SVt_IV) {
+        assert(!SvGMAGICAL(sv));
+        if (SvREADONLY(sv))
+            Perl_croak_no_modify();
+
+        if (SvROK(sv)) {
+            if (SvWEAKREF(sv))
+                sv_unref_flags(sv, 0);
+            else {
+                SV *rv = SvRV(sv);
+                SvFLAGS(sv) = type; /* quickly turn off all flags */
+                SvREFCNT_dec_NN(rv);
+                return;
+            }
+        }
+        SvFLAGS(sv) = type; /* quickly turn off all flags */
+        return;
+    }
+
+    if (SvIS_FREED(sv))
+        Perl_croak(aTHX_ "panic: attempt to undefine a freed scalar %p",
+            (void *)sv);
+
+    SV_CHECK_THINKFIRST_COW_DROP(sv);
+
+    if (isGV_with_GP(sv))
+        Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
+                       "Undefined value assigned to typeglob");
+
+    SvOK_off(sv);
+}
+
+
+

 /*
 =for apidoc sv_setsv_mg
 
 /*
 =for apidoc sv_setsv_mg
 


@@ -10272,7 +10330,7 @@ Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const p
     PERL_ARGS_ASSERT_SV_SETREF_PV;
 
     if (!pv) {
     PERL_ARGS_ASSERT_SV_SETREF_PV;
 
     if (!pv) {

-       sv_setsv(rv, &PL_sv_undef);
+       sv_set_undef(rv);

        SvSETMAGIC(rv);
     }
     else
        SvSETMAGIC(rv);
     }
     else

diff --git a/t/perf/benchmarks b/t/perf/benchmarks
index 6386f47..92411a2 100644 (file)
--- a/t/perf/benchmarks
+++ b/t/perf/benchmarks
@@ -320,6 +320,11 @@
         setup   => 'my ($x,$y,$z)',
         code    => '($x,$y,$z) = ()',
     },
         setup   => 'my ($x,$y,$z)',
         code    => '($x,$y,$z) = ()',
     },

+    'expr::aassign::3lref_empty' => {
+        desc    => 'three lexical ref vars assigned empty',
+        setup   => 'my ($x,$y,$z); my $r = []; ',
+        code    => '($x,$y,$z) = ($r,$r,$r); ($x,$y,$z) = ()',
+    },

     'expr::aassign::pa_empty' => {
         desc    => 'package array assigned empty',
         setup   => '',
     'expr::aassign::pa_empty' => {
         desc    => 'package array assigned empty',
         setup   => '',

diff --git a/util.c b/util.c
index adbe51d..02c84c8 100644 (file)
--- a/util.c
+++ b/util.c
@@ -4083,8 +4083,8 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in
 
 
 #define SV_CWD_RETURN_UNDEF \
 
 
 #define SV_CWD_RETURN_UNDEF \

-sv_setsv(sv, &PL_sv_undef); \
-return FALSE
+    sv_set_undef(sv); \
+    return FALSE

 
 #define SV_CWD_ISDOT(dp) \
     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
 
 #define SV_CWD_ISDOT(dp) \
     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \


@@ -4128,8 +4128,7 @@ Perl_getcwd_sv(pTHX_ SV *sv)
            return TRUE;
        }
        else {
            return TRUE;
        }
        else {

-           sv_setsv(sv, &PL_sv_undef);
-           return FALSE;
+           SV_CWD_RETURN_UNDEF;

        }
     }
 
        }
     }