Shared hash key scalars can be safely copied as shared hash key scalars

[perl5.git] / sv.c

diff --git a/sv.c b/sv.c
index aa07053..dd2c876 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -4443,10 +4443,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
        (void)SvPOK_only(dstr);
 
        if (
        (void)SvPOK_only(dstr);
 
        if (

-#ifdef PERL_COPY_ON_WRITE

             (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
             &&
             (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
             &&

-#endif

             !(isSwipe =
                  (sflags & SVs_TEMP) &&   /* slated for free anyway? */
                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
             !(isSwipe =
                  (sflags & SVs_TEMP) &&   /* slated for free anyway? */
                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */


@@ -4472,7 +4470,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
         } else {
             /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
                be true in here.  */
         } else {
             /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
                be true in here.  */

-#ifdef PERL_COPY_ON_WRITE

             /* Either it's a shared hash key, or it's suitable for
                copy-on-write or we can swipe the string.  */
             if (DEBUG_C_TEST) {
             /* Either it's a shared hash key, or it's suitable for
                copy-on-write or we can swipe the string.  */
             if (DEBUG_C_TEST) {


@@ -4480,6 +4477,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
                 sv_dump(sstr);
                 sv_dump(dstr);
             }
                 sv_dump(sstr);
                 sv_dump(dstr);
             }

+#ifdef PERL_COPY_ON_WRITE

             if (!isSwipe) {
                 /* I believe I should acquire a global SV mutex if
                    it's a COW sv (not a shared hash key) to stop
             if (!isSwipe) {
                 /* I believe I should acquire a global SV mutex if
                    it's a COW sv (not a shared hash key) to stop


@@ -4507,19 +4505,21 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
                    Safefree(SvPVX_const(dstr));
            }
 
                    Safefree(SvPVX_const(dstr));
            }
 

-#ifdef PERL_COPY_ON_WRITE

             if (!isSwipe) {
                 /* making another shared SV.  */
                 STRLEN cur = SvCUR(sstr);
                 STRLEN len = SvLEN(sstr);
                assert (SvTYPE(dstr) >= SVt_PVIV);
             if (!isSwipe) {
                 /* making another shared SV.  */
                 STRLEN cur = SvCUR(sstr);
                 STRLEN len = SvLEN(sstr);
                assert (SvTYPE(dstr) >= SVt_PVIV);

+#ifdef PERL_COPY_ON_WRITE

                 if (len) {
                     /* SvIsCOW_normal */
                     /* splice us in between source and next-after-source.  */
                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
                     SV_COW_NEXT_SV_SET(sstr, dstr);
                     SvPV_set(dstr, SvPVX(sstr));
                 if (len) {
                     /* SvIsCOW_normal */
                     /* splice us in between source and next-after-source.  */
                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
                     SV_COW_NEXT_SV_SET(sstr, dstr);
                     SvPV_set(dstr, SvPVX(sstr));

-                } else {
+                } else
+#endif
+               {

                     /* SvIsCOW_shared_hash */
                     UV hash = SvUVX(sstr);
                     DEBUG_C(PerlIO_printf(Perl_debug_log,
                     /* SvIsCOW_shared_hash */
                     UV hash = SvUVX(sstr);
                     DEBUG_C(PerlIO_printf(Perl_debug_log,


@@ -4536,7 +4536,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
                 /* Relesase a global SV mutex.  */
             }
             else
                 /* Relesase a global SV mutex.  */
             }
             else

-#endif

                 {      /* Passes the swipe test.  */
                 SvPV_set(dstr, SvPVX(sstr));
                 SvLEN_set(dstr, SvLEN(sstr));
                 {      /* Passes the swipe test.  */
                 SvPV_set(dstr, SvPVX(sstr));
                 SvLEN_set(dstr, SvLEN(sstr));


@@ -4956,7 +4955,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
 #else
     if (SvREADONLY(sv)) {
        if (SvFAKE(sv)) {
 #else
     if (SvREADONLY(sv)) {
        if (SvFAKE(sv)) {

-           char *pvx = SvPVX_const(sv);
+           const char *pvx = SvPVX_const(sv);

            const int is_utf8 = SvUTF8(sv);
            STRLEN len = SvCUR(sv);
             U32 hash   = SvUVX(sv);
            const int is_utf8 = SvUTF8(sv);
            STRLEN len = SvCUR(sv);
             U32 hash   = SvUVX(sv);


@@ -7601,6 +7600,61 @@ Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
     return sv;
 }
 
     return sv;
 }
 

+
+/*
+=for apidoc newSVpv_hek
+
+Creates a new SV from the hash key structure.  It will generate scalars that
+point to the shared string table where possible. Returns a new (undefined)
+SV if the hek is NULL.
+
+=cut
+*/
+
+SV *
+Perl_newSVhek(pTHX_ const HEK *hek)
+{
+    if (!hek) {
+       SV *sv;
+
+       new_SV(sv);
+       return sv;
+    }
+
+    if (HEK_LEN(hek) == HEf_SVKEY) {
+       return newSVsv(*(SV**)HEK_KEY(hek));
+    } else {
+       const int flags = HEK_FLAGS(hek);
+       if (flags & HVhek_WASUTF8) {
+           /* Trouble :-)
+              Andreas would like keys he put in as utf8 to come back as utf8
+           */
+           STRLEN utf8_len = HEK_LEN(hek);
+           U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
+           SV *sv = newSVpvn ((char*)as_utf8, utf8_len);
+
+           SvUTF8_on (sv);
+           Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
+           return sv;
+       } else if (flags & HVhek_REHASH) {
+           /* We don't have a pointer to the hv, so we have to replicate the
+              flag into every HEK. This hv is using custom a hasing
+              algorithm. Hence we can't return a shared string scalar, as
+              that would contain the (wrong) hash value, and might get passed
+              into an hv routine with a regular hash  */
+
+           SV *sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
+           if (HEK_UTF8(hek))
+               SvUTF8_on (sv);
+           return sv;
+       }
+       /* This will be overwhelminly the most common case.  */
+       return newSVpvn_share(HEK_KEY(hek),
+                             (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
+                             HEK_HASH(hek));
+    }
+}
+

 /*
 =for apidoc newSVpvn_share
 
 /*
 =for apidoc newSVpvn_share
 


@@ -11472,10 +11526,9 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
 static void
 do_mark_cloneable_stash(pTHX_ SV *sv)
 {
 static void
 do_mark_cloneable_stash(pTHX_ SV *sv)
 {

-    const char *hvname = HvNAME_get((HV*)sv);
+    const HEK *hvname = HvNAME_HEK((HV*)sv);

     if (hvname) {
        GV* cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
     if (hvname) {
        GV* cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);

-       STRLEN len = HvNAMELEN_get((HV*)sv);

        SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
        if (cloner && GvCV(cloner)) {
            dSP;
        SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
        if (cloner && GvCV(cloner)) {
            dSP;


@@ -11484,7 +11537,7 @@ do_mark_cloneable_stash(pTHX_ SV *sv)
            ENTER;
            SAVETMPS;
            PUSHMARK(SP);
            ENTER;
            SAVETMPS;
            PUSHMARK(SP);

-           XPUSHs(sv_2mortal(newSVpvn(hvname, len)));
+           XPUSHs(sv_2mortal(newSVhek(hvname)));

            PUTBACK;
            call_sv((SV*)GvCV(cloner), G_SCALAR);
            SPAGAIN;
            PUTBACK;
            call_sv((SV*)GvCV(cloner), G_SCALAR);
            SPAGAIN;


@@ -11577,6 +11630,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
      * constants; they need to be allocated as common memory and just
      * their pointers copied. */
 
      * constants; they need to be allocated as common memory and just
      * their pointers copied. */
 

+    IV i;

     CLONE_PARAMS clone_params;
     CLONE_PARAMS* param = &clone_params;
 
     CLONE_PARAMS clone_params;
     CLONE_PARAMS* param = &clone_params;
 


@@ -12334,7 +12388,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
            ENTER;
            SAVETMPS;
            PUSHMARK(SP);
            ENTER;
            SAVETMPS;
            PUSHMARK(SP);

-           XPUSHs(sv_2mortal(newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash))));
+           XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash))));

            PUTBACK;
            call_sv((SV*)GvCV(cloner), G_DISCARD);
            FREETMPS;
            PUTBACK;
            call_sv((SV*)GvCV(cloner), G_DISCARD);
            FREETMPS;