make opslot_slab an offset in current slab

[perl5.git] / av.c

diff --git a/av.c b/av.c
index 21828a9..f10f124 100644 (file)
--- a/av.c
+++ b/av.c
@@ -89,7 +89,7 @@ Perl_av_extend_guts(pTHX_ AV *av, SSize_t key, SSize_t *maxp, SV ***allocp,
 
     if (key < -1) /* -1 is legal */
         Perl_croak(aTHX_
 
     if (key < -1) /* -1 is legal */
         Perl_croak(aTHX_

-            "panic: av_extend_guts() negative count (%"IVdf")", (IV)key);
+            "panic: av_extend_guts() negative count (%" IVdf ")", (IV)key);

 
     if (key > *maxp) {
        SV** ary;
 
     if (key > *maxp) {
        SV** ary;


@@ -140,17 +140,13 @@ Perl_av_extend_guts(pTHX_ AV *av, SSize_t key, SSize_t *maxp, SV ***allocp,
                             ? SSize_t_MAX : key + newmax;
              resize:
                {
                             ? SSize_t_MAX : key + newmax;
              resize:
                {

-#ifdef PERL_MALLOC_WRAP /* Duplicated in pp_hot.c */
-                   static const char oom_array_extend[] =
-                       "Out of memory during array extend";
-#endif

                     /* it should really be newmax+1 here, but if newmax
                      * happens to equal SSize_t_MAX, then newmax+1 is
                      * undefined. This means technically we croak one
                      * index lower than we should in theory; in practice
                      * its unlikely the system has SSize_t_MAX/sizeof(SV*)
                      * bytes to spare! */
                     /* it should really be newmax+1 here, but if newmax
                      * happens to equal SSize_t_MAX, then newmax+1 is
                      * undefined. This means technically we croak one
                      * index lower than we should in theory; in practice
                      * its unlikely the system has SSize_t_MAX/sizeof(SV*)
                      * bytes to spare! */

-                   MEM_WRAP_CHECK_1(newmax, SV*, oom_array_extend);
+                   MEM_WRAP_CHECK_s(newmax, SV*, "Out of memory during array extend");

                }
 #ifdef STRESS_REALLOC
                {
                }
 #ifdef STRESS_REALLOC
                {


@@ -176,12 +172,8 @@ Perl_av_extend_guts(pTHX_ AV *av, SSize_t key, SSize_t *maxp, SV ***allocp,
            else {
                newmax = key < 3 ? 3 : key;
                {
            else {
                newmax = key < 3 ? 3 : key;
                {

-#ifdef PERL_MALLOC_WRAP /* Duplicated in pp_hot.c */
-                   static const char oom_array_extend[] =
-                       "Out of memory during array extend";
-#endif

                     /* see comment above about newmax+1*/
                     /* see comment above about newmax+1*/

-                   MEM_WRAP_CHECK_1(newmax, SV*, oom_array_extend);
+                   MEM_WRAP_CHECK_s(newmax, SV*, "Out of memory during array extend");

                }
                Newx(*allocp, newmax+1, SV*);
                ary = *allocp + 1;
                }
                Newx(*allocp, newmax+1, SV*);
                ary = *allocp + 1;


@@ -210,7 +202,7 @@ value is non-null before dereferencing it to a C<SV*>.
 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 more information on how to use this function on tied arrays. 
 
 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 more information on how to use this function on tied arrays. 
 

-The rough perl equivalent is C<$myarray[$idx]>.
+The rough perl equivalent is C<$myarray[$key]>.

 
 =cut
 */
 
 =cut
 */


@@ -305,7 +297,7 @@ Note that the caller is responsible for suitably incrementing the reference
 count of C<val> before the call, and decrementing it if the function
 returned C<NULL>.
 
 count of C<val> before the call, and decrementing it if the function
 returned C<NULL>.
 

-Approximate Perl equivalent: C<$myarray[$key] = $val;>.
+Approximate Perl equivalent: C<splice(@myarray, $key, 1, $val)>.

 
 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 more information on how to use this function on tied arrays.
 
 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 more information on how to use this function on tied arrays.


@@ -364,8 +356,8 @@ Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val)
        }
        AvFILLp(av) = key;
     }
        }
        AvFILLp(av) = key;
     }

-    else if (AvREAL(av))
-       SvREFCNT_dec(ary[key]);
+    else if (AvREAL(av) && LIKELY(ary[key] != val))
+        SvREFCNT_dec(ary[key]);

     ary[key] = val;
     if (SvSMAGICAL(av)) {
        const MAGIC *mg = SvMAGIC(av);
     ary[key] = val;
     if (SvSMAGICAL(av)) {
        const MAGIC *mg = SvMAGIC(av);


@@ -409,13 +401,18 @@ Perl_av_make(pTHX_ SSize_t size, SV **strp)
     if (size) {                /* "defined" was returning undef for size==0 anyway. */
         SV** ary;
         SSize_t i;
     if (size) {                /* "defined" was returning undef for size==0 anyway. */
         SV** ary;
         SSize_t i;

+        SSize_t orig_ix;
+

        Newx(ary,size,SV*);
        AvALLOC(av) = ary;
        AvARRAY(av) = ary;
        AvMAX(av) = size - 1;
        AvFILLp(av) = -1;
        Newx(ary,size,SV*);
        AvALLOC(av) = ary;
        AvARRAY(av) = ary;
        AvMAX(av) = size - 1;
        AvFILLp(av) = -1;

-       ENTER;
-       SAVEFREESV(av);
+        /* avoid av being leaked if croak when calling magic below */
+        EXTEND_MORTAL(1);
+        PL_tmps_stack[++PL_tmps_ix] = (SV*)av;
+        orig_ix = PL_tmps_ix;
+

        for (i = 0; i < size; i++) {
            assert (*strp);
 
        for (i = 0; i < size; i++) {
            assert (*strp);
 


@@ -430,8 +427,11 @@ Perl_av_make(pTHX_ SSize_t size, SV **strp)
                           SV_DO_COW_SVSETSV|SV_NOSTEAL);
            strp++;
        }
                           SV_DO_COW_SVSETSV|SV_NOSTEAL);
            strp++;
        }

-       SvREFCNT_inc_simple_void_NN(av);
-       LEAVE;
+        /* disarm av's leak guard */
+        if (LIKELY(PL_tmps_ix == orig_ix))
+            PL_tmps_ix--;
+        else
+            PL_tmps_stack[orig_ix] = &PL_sv_undef;

     }
     return av;
 }
     }
     return av;
 }


@@ -457,6 +457,7 @@ Perl_av_clear(pTHX_ AV *av)
 {
     SSize_t extra;
     bool real;
 {
     SSize_t extra;
     bool real;

+    SSize_t orig_ix = 0;

 
     PERL_ARGS_ASSERT_AV_CLEAR;
     assert(SvTYPE(av) == SVt_PVAV);
 
     PERL_ARGS_ASSERT_AV_CLEAR;
     assert(SvTYPE(av) == SVt_PVAV);


@@ -482,11 +483,15 @@ Perl_av_clear(pTHX_ AV *av)
     if (AvMAX(av) < 0)
        return;
 
     if (AvMAX(av) < 0)
        return;
 

-    if ((real = !!AvREAL(av))) {
+    if ((real = cBOOL(AvREAL(av)))) {

        SV** const ary = AvARRAY(av);
        SSize_t index = AvFILLp(av) + 1;
        SV** const ary = AvARRAY(av);
        SSize_t index = AvFILLp(av) + 1;

-       ENTER;
-       SAVEFREESV(SvREFCNT_inc_simple_NN(av));
+
+        /* avoid av being freed when calling destructors below */
+        EXTEND_MORTAL(1);
+        PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av);
+        orig_ix = PL_tmps_ix;
+

        while (index) {
            SV * const sv = ary[--index];
            /* undef the slot before freeing the value, because a
        while (index) {
            SV * const sv = ary[--index];
            /* undef the slot before freeing the value, because a


@@ -501,7 +506,14 @@ Perl_av_clear(pTHX_ AV *av)
        AvARRAY(av) = AvALLOC(av);
     }
     AvFILLp(av) = -1;
        AvARRAY(av) = AvALLOC(av);
     }
     AvFILLp(av) = -1;

-    if (real) LEAVE;
+    if (real) {
+        /* disarm av's premature free guard */
+        if (LIKELY(PL_tmps_ix == orig_ix))
+            PL_tmps_ix--;
+        else
+            PL_tmps_stack[orig_ix] = &PL_sv_undef;
+        SvREFCNT_dec_NN(av);
+    }

 }
 
 /*
 }
 
 /*


@@ -522,6 +534,7 @@ void
 Perl_av_undef(pTHX_ AV *av)
 {
     bool real;
 Perl_av_undef(pTHX_ AV *av)
 {
     bool real;

+    SSize_t orig_ix = PL_tmps_ix; /* silence bogus warning about possible unitialized use */

 
     PERL_ARGS_ASSERT_AV_UNDEF;
     assert(SvTYPE(av) == SVt_PVAV);
 
     PERL_ARGS_ASSERT_AV_UNDEF;
     assert(SvTYPE(av) == SVt_PVAV);


@@ -530,10 +543,15 @@ Perl_av_undef(pTHX_ AV *av)
     if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied)) 
        av_fill(av, -1);
 
     if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied)) 
        av_fill(av, -1);
 

-    if ((real = !!AvREAL(av))) {
+    real = cBOOL(AvREAL(av));
+    if (real) {

        SSize_t key = AvFILLp(av) + 1;
        SSize_t key = AvFILLp(av) + 1;

-       ENTER;
-       SAVEFREESV(SvREFCNT_inc_simple_NN(av));
+
+        /* avoid av being freed when calling destructors below */
+        EXTEND_MORTAL(1);
+        PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av);
+        orig_ix = PL_tmps_ix;
+

        while (key)
            SvREFCNT_dec(AvARRAY(av)[--key]);
     }
        while (key)
            SvREFCNT_dec(AvARRAY(av)[--key]);
     }


@@ -544,7 +562,14 @@ Perl_av_undef(pTHX_ AV *av)
     AvMAX(av) = AvFILLp(av) = -1;
 
     if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
     AvMAX(av) = AvFILLp(av) = -1;
 
     if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));

-    if(real) LEAVE;
+    if (real) {
+        /* disarm av's premature free guard */
+        if (LIKELY(PL_tmps_ix == orig_ix))
+            PL_tmps_ix--;
+        else
+            PL_tmps_stack[orig_ix] = &PL_sv_undef;
+        SvREFCNT_dec_NN(av);
+    }

 }
 
 /*
 }
 
 /*


@@ -573,7 +598,7 @@ Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
 Pushes an SV (transferring control of one reference count) onto the end of the
 array.  The array will grow automatically to accommodate the addition.
 
 Pushes an SV (transferring control of one reference count) onto the end of the
 array.  The array will grow automatically to accommodate the addition.
 

-Perl equivalent: C<push @myarray, $elem;>.
+Perl equivalent: C<push @myarray, $val;>.

 
 =cut
 */
 
 =cut
 */


@@ -661,10 +686,9 @@ Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
 =for apidoc av_unshift
 
 Unshift the given number of C<undef> values onto the beginning of the
 =for apidoc av_unshift
 
 Unshift the given number of C<undef> values onto the beginning of the

-array.  The array will grow automatically to accommodate the addition.  You
-must then use C<av_store> to assign values to these new elements.
+array.  The array will grow automatically to accommodate the addition.

 
 

-Perl equivalent: S<C<unshift @myarray, ( (undef) x $n );>>
+Perl equivalent: S<C<unshift @myarray, ((undef) x $num);>>

 
 =cut
 */
 
 =cut
 */


@@ -848,11 +872,13 @@ Perl_av_fill(pTHX_ AV *av, SSize_t fill)
 /*
 =for apidoc av_delete
 
 /*
 =for apidoc av_delete
 

-Deletes the element indexed by C<key> from the array, makes the element mortal,
-and returns it.  If C<flags> equals C<G_DISCARD>, the element is freed and null
-is returned.  Perl equivalent: S<C<my $elem = delete($myarray[$idx]);>> for the
-non-C<G_DISCARD> version and a void-context S<C<delete($myarray[$idx]);>> for the
-C<G_DISCARD> version.
+Deletes the element indexed by C<key> from the array, makes the element
+mortal, and returns it.  If C<flags> equals C<G_DISCARD>, the element is
+freed and NULL is returned. NULL is also returned if C<key> is out of
+range.
+
+Perl equivalent: S<C<splice(@myarray, $key, 1, undef)>> (with the
+C<splice> in void context if C<G_DISCARD> is present).

 
 =cut
 */
 
 =cut
 */


@@ -981,6 +1007,9 @@ Perl_av_exists(pTHX_ AV *av, SSize_t key)
 
     if (key <= AvFILLp(av) && AvARRAY(av)[key])
     {
 
     if (key <= AvFILLp(av) && AvARRAY(av)[key])
     {

+       if (SvSMAGICAL(AvARRAY(av)[key])
+        && mg_find(AvARRAY(av)[key], PERL_MAGIC_nonelem))
+           return FALSE;

        return TRUE;
     }
     else
        return TRUE;
     }
     else


@@ -1023,17 +1052,27 @@ Perl_av_iter_p(pTHX_ AV *av) {
     PERL_ARGS_ASSERT_AV_ITER_P;
     assert(SvTYPE(av) == SVt_PVAV);
 
     PERL_ARGS_ASSERT_AV_ITER_P;
     assert(SvTYPE(av) == SVt_PVAV);
 

-#if IVSIZE == I32SIZE
-    return (IV *)&(mg->mg_len);
-#else
-    if (!mg->mg_ptr) {
-       IV *temp;
-       mg->mg_len = IVSIZE;
-       Newxz(temp, 1, IV);
-       mg->mg_ptr = (char *) temp;
+    if (sizeof(IV) == sizeof(SSize_t)) {
+       return (IV *)&(mg->mg_len);
+    } else {
+       if (!mg->mg_ptr) {
+           IV *temp;
+           mg->mg_len = IVSIZE;
+           Newxz(temp, 1, IV);
+           mg->mg_ptr = (char *) temp;
+       }
+       return (IV *)mg->mg_ptr;

     }
     }

-    return (IV *)mg->mg_ptr;
-#endif
+}
+
+SV *
+Perl_av_nonelem(pTHX_ AV *av, SSize_t ix) {
+    SV * const sv = newSV(0);
+    PERL_ARGS_ASSERT_AV_NONELEM;
+    if (!av_store(av,ix,sv))
+       return sv_2mortal(sv); /* has tie magic */
+    sv_magic(sv, NULL, PERL_MAGIC_nonelem, NULL, 0);
+    return sv;

 }
 
 /*
 }
 
 /*