Re-implement the SvOOK() hack to store the offset as a BER encoded
authorNicholas Clark <nick@ccl4.org>
Fri, 4 Jan 2008 23:12:01 +0000 (23:12 +0000)
committerNicholas Clark <nick@ccl4.org>
Fri, 4 Jan 2008 23:12:01 +0000 (23:12 +0000)
number in the part of the PVX that is being released. (It will always
fit, as chopping off 1 byte gives just enough space for recording a
delta of up to 127). This allows SvOOK() to co-exist with SvIOK_on(),
which means all the calls to SvOOK_off() [with the possibility of a
call to sv_backoff()] in SvIOK_on() can be removed. This ought to make
a lot of straight line code a little bit simpler.
OOK()d scalars can now be SVt_PV, as the IVX isn't needed.

p4raw-id: //depot/perl@32836

dump.c
embed.fnc
embed.h
global.sym
proto.h
sv.c
sv.h

diff --git a/dump.c b/dump.c
index 90f44ee..9312bf4 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -1539,8 +1539,6 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
            Perl_dump_indent(aTHX_ level, file, "  UV = %"UVuf, (UV)SvUVX(sv));
        else
            Perl_dump_indent(aTHX_ level, file, "  IV = %"IVdf, (IV)SvIVX(sv));
-       if (SvOOK(sv))
-           PerlIO_printf(file, "  (OFFSET)");
 #ifdef PERL_OLD_COPY_ON_WRITE
        if (SvIsCOW_shared_hash(sv))
            PerlIO_printf(file, "  (HASH)");
@@ -1578,9 +1576,17 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
     }
     if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
        if (SvPVX_const(sv)) {
+           UV delta = SvOOK(sv) ? sv_read_offset(sv) : 0;
+           if (SvOOK(sv)) {
+               Perl_dump_indent(aTHX_ level, file,"  OFFSET = %"UVuf"\n",
+                                delta);
+           }
            Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
-           if (SvOOK(sv))
-               PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim));
+           if (SvOOK(sv)) {
+               PerlIO_printf(file, "( %s . ) ",
+                             pv_display(d, SvPVX_const(sv) - delta, delta, 0,
+                                        pvlim));
+           }
            PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
            if (SvUTF8(sv)) /* the 6?  \x{....} */
                PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
index d36e2fd..2ae0c3b 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -881,6 +881,7 @@ Apd |void   |sv_pos_b2u     |NULLOK SV* sv|NN I32* offsetp
 Amdb   |char*  |sv_pvn_force   |NN SV* sv|NULLOK STRLEN* lp
 Apd    |char*  |sv_pvutf8n_force|NN SV* sv|NULLOK STRLEN* lp
 Apd    |char*  |sv_pvbyten_force|NN SV* sv|NULLOK STRLEN* lp
+Ap     |UV     |sv_read_offset |NN const SV *const sv
 Apd    |char*  |sv_recode_to_utf8      |NN SV* sv|NN SV *encoding
 Apd    |bool   |sv_cat_decode  |NN SV* dsv|NN SV *encoding|NN SV *ssv|NN int *offset \
                                |NN char* tstr|int tlen
diff --git a/embed.h b/embed.h
index 377266a..72b4640 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define sv_pos_b2u             Perl_sv_pos_b2u
 #define sv_pvutf8n_force       Perl_sv_pvutf8n_force
 #define sv_pvbyten_force       Perl_sv_pvbyten_force
+#define sv_read_offset         Perl_sv_read_offset
 #define sv_recode_to_utf8      Perl_sv_recode_to_utf8
 #define sv_cat_decode          Perl_sv_cat_decode
 #define sv_reftype             Perl_sv_reftype
 #define sv_pos_b2u(a,b)                Perl_sv_pos_b2u(aTHX_ a,b)
 #define sv_pvutf8n_force(a,b)  Perl_sv_pvutf8n_force(aTHX_ a,b)
 #define sv_pvbyten_force(a,b)  Perl_sv_pvbyten_force(aTHX_ a,b)
+#define sv_read_offset(a)      Perl_sv_read_offset(aTHX_ a)
 #define sv_recode_to_utf8(a,b) Perl_sv_recode_to_utf8(aTHX_ a,b)
 #define sv_cat_decode(a,b,c,d,e,f)     Perl_sv_cat_decode(aTHX_ a,b,c,d,e,f)
 #define sv_reftype(a,b)                Perl_sv_reftype(aTHX_ a,b)
index 021d86b..e5f9d66 100644 (file)
@@ -539,6 +539,7 @@ Perl_sv_pos_b2u
 Perl_sv_pvn_force
 Perl_sv_pvutf8n_force
 Perl_sv_pvbyten_force
+Perl_sv_read_offset
 Perl_sv_recode_to_utf8
 Perl_sv_cat_decode
 Perl_sv_reftype
diff --git a/proto.h b/proto.h
index 5bbb593..d276e3a 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -2355,6 +2355,9 @@ PERL_CALLCONV char*       Perl_sv_pvutf8n_force(pTHX_ SV* sv, STRLEN* lp)
 PERL_CALLCONV char*    Perl_sv_pvbyten_force(pTHX_ SV* sv, STRLEN* lp)
                        __attribute__nonnull__(pTHX_1);
 
+PERL_CALLCONV UV       Perl_sv_read_offset(pTHX_ const SV *const sv)
+                       __attribute__nonnull__(pTHX_1);
+
 PERL_CALLCONV char*    Perl_sv_recode_to_utf8(pTHX_ SV* sv, SV *encoding)
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_2);
diff --git a/sv.c b/sv.c
index b514753..883b97f 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -1397,27 +1397,16 @@ wrapper instead.
 int
 Perl_sv_backoff(pTHX_ register SV *sv)
 {
+    UV delta = sv_read_offset(sv);
+    const char * const s = SvPVX_const(sv);
     PERL_UNUSED_CONTEXT;
     assert(SvOOK(sv));
     assert(SvTYPE(sv) != SVt_PVHV);
     assert(SvTYPE(sv) != SVt_PVAV);
-    if (SvIVX(sv)) {
-       const char * const s = SvPVX_const(sv);
-#ifdef DEBUGGING
-       /* Validate the preceding buffer's sentinels to verify that no-one is
-          using it.  */
-       const U8 *p = (const U8*) s;
-       const U8 *const real_start = p - SvIVX(sv);
-       while (p > real_start) {
-           --p;
-           assert (*p == (U8)PTR2UV(p));
-       }
-#endif
-       SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
-       SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
-       SvIV_set(sv, 0);
-       Move(s, SvPVX(sv), SvCUR(sv)+1, char);
-    }
+
+    SvLEN_set(sv, SvLEN(sv) + delta);
+    SvPV_set(sv, SvPVX(sv) - delta);
+    Move(s, SvPVX(sv), SvCUR(sv)+1, char);
     SvFLAGS(sv) &= ~SVf_OOK;
     return 0;
 }
@@ -3779,7 +3768,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
            SvNV_set(dstr, SvNVX(sstr));
        }
        if (sflags & SVp_IOK) {
-           SvOOK_off(dstr);
            SvIV_set(dstr, SvIVX(sstr));
            /* Must do this otherwise some other overloaded use of 0x80000000
               gets confused. I guess SVpbm_VALID */
@@ -4202,6 +4190,43 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
        sv_unglob(sv);
 }
 
+UV
+Perl_sv_read_offset(pTHX_ const SV *const sv) {
+    U8 *p;
+    UV delta = 0;
+    U8 c;
+
+    if (!SvOOK(sv))
+       return 0;
+    p = (U8*)SvPVX_const(sv);
+    if (!p)
+       return 0;
+
+    c = *--p;
+    delta = c & 0x7F;
+    while ((c & 0x80)) {
+       UV const last_delta = delta;
+       delta <<= 7;
+       if (delta < last_delta)
+           Perl_croak(aTHX_ "panic: overflow in sv_read_offset from %"UVuf
+                      " to %"UVuf, last_delta, delta);
+       c = *--p;
+       delta |= c & 0x7F;
+    }
+#ifdef DEBUGGING
+    {
+       /* Validate the preceding buffer's sentinels to verify that no-one is
+          using it.  */
+       const U8 *const real_start = (U8 *) SvPVX_const(sv) - delta;
+       while (p > real_start) {
+           --p;
+           assert (*p == (U8)PTR2UV(p));
+       }
+    }
+#endif
+    return delta;
+}
+
 /*
 =for apidoc sv_chop
 
@@ -4219,6 +4244,12 @@ void
 Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
 {
     register STRLEN delta;
+    UV old_delta;
+    U8 *p;
+#ifdef DEBUGGING
+    const U8 *real_start;
+#endif
+
     if (!ptr || !SvPOKp(sv))
        return;
     delta = ptr - SvPVX_const(sv);
@@ -4228,8 +4259,6 @@ Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
     }
     assert(ptr > SvPVX_const(sv));
     SV_CHECK_THINKFIRST(sv);
-    if (SvTYPE(sv) < SVt_PVIV)
-       sv_upgrade(sv,SVt_PVIV);
 
     if (!SvOOK(sv)) {
        if (!SvLEN(sv)) { /* make copy of shared string */
@@ -4239,27 +4268,47 @@ Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
            Move(pvx,SvPVX(sv),len,char);
            *SvEND(sv) = '\0';
        }
-       SvIV_set(sv, 0);
-       /* Same SvOOK_on but SvOOK_on does a SvIOK_off
-          and we do that anyway inside the SvNIOK_off
-       */
        SvFLAGS(sv) |= SVf_OOK;
+       old_delta = 0;
+    } else {
+       old_delta = sv_read_offset(sv);
     }
-    SvNIOK_off(sv);
     SvLEN_set(sv, SvLEN(sv) - delta);
     SvCUR_set(sv, SvCUR(sv) - delta);
     SvPV_set(sv, SvPVX(sv) + delta);
-    SvIV_set(sv, SvIVX(sv) + delta);
+
+    p = (U8 *)SvPVX_const(sv);
+
+    delta += old_delta;
+
 #ifdef DEBUGGING
-    {
-       /* Fill the preceding buffer with sentinals to verify that no-one is
-          using it.  */
-       U8 *p = (U8*) SvPVX(sv);
-       const U8 *const real_start = p - SvIVX(sv);
-       while (p > real_start) {
-           --p;
-           *p = (U8)PTR2UV(p);
-       }
+    real_start = p - delta;
+#endif
+
+    if (delta < 0x80) {
+       *--p = (U8) delta;
+    } else {
+       /* Code lovingly ripped from pp_pack.c:  */
+       U8   buf[(sizeof(UV)*CHAR_BIT)/7+1];
+       U8  *in = buf;
+       STRLEN len;
+       do {
+           *in++ = (U8)((delta & 0x7f) | 0x80);
+           delta >>= 7;
+       } while (delta);
+       buf[0] &= 0x7f; /* clear continue bit */
+
+       len = in - buf;
+       p -= len;
+       Copy(buf, p, len, U8);
+    }
+
+#ifdef DEBUGGING
+    /* Fill the preceding buffer with sentinals to verify that no-one is
+       using it.  */
+    while (p > real_start) {
+       --p;
+       *p = (U8)PTR2UV(p);
     }
 #endif
 }
@@ -5278,13 +5327,13 @@ Perl_sv_clear(pTHX_ register SV *sv)
     case SVt_PVMG:
     case SVt_PVNV:
     case SVt_PVIV:
+    case SVt_PV:
       freescalar:
        /* Don't bother with SvOOK_off(sv); as we're only going to free it.  */
        if (SvOOK(sv)) {
-           SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv));
+           SvPV_set(sv, SvPVX_mutable(sv) - sv_read_offset(sv));
            /* Don't even bother with turning off the OOK flag.  */
        }
-    case SVt_PV:
        if (SvROK(sv)) {
            SV * const target = SvRV(sv);
            if (SvWEAKREF(sv))
diff --git a/sv.h b/sv.h
index 960a059..afa18dc 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -761,7 +761,7 @@ Set the actual length of the string which is in the SV.  See C<SvIV_set>.
 
 #define SvOKp(sv)              (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK))
 #define SvIOKp(sv)             (SvFLAGS(sv) & SVp_IOK)
-#define SvIOKp_on(sv)          (assert_not_glob(sv) SvRELEASE_IVX(sv), \
+#define SvIOKp_on(sv)          (assert_not_glob(sv) SvRELEASE_IVX_(sv) \
                                    SvFLAGS(sv) |= SVp_IOK)
 #define SvNOKp(sv)             (SvFLAGS(sv) & SVp_NOK)
 #define SvNOKp_on(sv)          (assert_not_glob(sv) SvFLAGS(sv) |= SVp_NOK)
@@ -770,7 +770,7 @@ Set the actual length of the string which is in the SV.  See C<SvIV_set>.
                                 SvFLAGS(sv) |= SVp_POK)
 
 #define SvIOK(sv)              (SvFLAGS(sv) & SVf_IOK)
-#define SvIOK_on(sv)           (assert_not_glob(sv) SvRELEASE_IVX(sv), \
+#define SvIOK_on(sv)           (assert_not_glob(sv) SvRELEASE_IVX_(sv) \
                                    SvFLAGS(sv) |= (SVf_IOK|SVp_IOK))
 #define SvIOK_off(sv)          (SvFLAGS(sv) &= ~(SVf_IOK|SVp_IOK|SVf_IVisUV))
 #define SvIOK_only(sv)         (SvOK_off(sv), \
@@ -1240,7 +1240,8 @@ the scalar's value cannot change unless written to.
                     if (SvLEN(sv)) {                                   \
                         assert(!SvROK(sv));                            \
                         if(SvOOK(sv)) {                                \
-                            SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv)); \
+                            SvPV_set(sv, SvPVX_mutable(sv)             \
+                                         - sv_read_offset(sv));        \
                             SvFLAGS(sv) &= ~SVf_OOK;                   \
                         }                                              \
                         Safefree(SvPVX(sv));                           \
@@ -1714,10 +1715,16 @@ Like C<sv_catsv> but doesn't process magic.
 
 #ifdef PERL_OLD_COPY_ON_WRITE
 #define SvRELEASE_IVX(sv)   \
-    ((SvIsCOW(sv) ? sv_force_normal_flags(sv, 0) : (void) 0), SvOOK_off(sv))
+    ((SvIsCOW(sv) ? sv_force_normal_flags(sv, 0) : (void) 0), 0)
 #  define SvIsCOW_normal(sv)   (SvIsCOW(sv) && SvLEN(sv))
+#  define SvRELEASE_IVX_(sv)   SvRELEASE_IVX(sv),
 #else
-#  define SvRELEASE_IVX(sv)   SvOOK_off(sv)
+#  define SvRELEASE_IVX(sv)   0
+/* This little game brought to you by the need to shut this warning up:
+mg.c: In function `Perl_magic_get':
+mg.c:1024: warning: left-hand operand of comma expression has no effect
+*/
+#  define SvRELEASE_IVX_(sv)  /**/
 #endif /* PERL_OLD_COPY_ON_WRITE */
 
 #define CAN_COW_MASK   (SVs_OBJECT|SVs_GMG|SVs_SMG|SVs_RMG|SVf_IOK|SVf_NOK| \