X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/f4d8be8b395cdacf05f8c461fb7e9ce0366ff56f..055663bc9d17f8e2ef5ef0a4233d89dd4a69d2a2:/av.c?ds=sidebyside diff --git a/av.c b/av.c index 8f8cda5..67815fc 100644 --- a/av.c +++ b/av.c @@ -15,10 +15,6 @@ * [p.476 of _The Lord of the Rings_, III/iv: "Treebeard"] */ -/* -=head1 Array Manipulation Functions -*/ - #include "EXTERN.h" #define PERL_IN_AV_C #include "perl.h" @@ -55,8 +51,13 @@ Perl_av_reify(pTHX_ AV *av) /* =for apidoc av_extend -Pre-extend an array. The C is the index to which the array should be -extended. +Pre-extend an array so that it is capable of storing values at indexes +C<0..key>. Thus C guarantees that the array can store 100 +elements, i.e. that C through C +on a plain array will work without any further memory allocation. + +If the av argument is a tied array then will call the C tied +array method with an argument of C<(key+1)>. =cut */ @@ -72,6 +73,15 @@ Perl_av_extend(pTHX_ AV *av, SSize_t key) mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied); if (mg) { SV *arg1 = sv_newmortal(); + /* NOTE: the API for av_extend() is NOT the same as the tie method EXTEND. + * + * The C function takes an *index* (assumes 0 indexed arrays) and ensures + * that the array is at least as large as the index provided. + * + * The tied array method EXTEND takes a *count* and ensures that the array + * is at least that many elements large. Thus we have to +1 the key when + * we call the tied method. + */ sv_setiv(arg1, (IV)(key + 1)); Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(EXTEND), G_DISCARD, 1, arg1); @@ -81,121 +91,116 @@ Perl_av_extend(pTHX_ AV *av, SSize_t key) } /* The guts of av_extend. *Not* for general use! */ +/* Also called directly from pp_assign, padlist_store, padnamelist_store */ void Perl_av_extend_guts(pTHX_ AV *av, SSize_t key, SSize_t *maxp, SV ***allocp, - SV ***arrayp) + SV ***arrayp) { PERL_ARGS_ASSERT_AV_EXTEND_GUTS; 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; - SSize_t tmp; - SSize_t newmax; - - if (av && *allocp != *arrayp) { - ary = *allocp + AvFILLp(av) + 1; - tmp = *arrayp - *allocp; - Move(*arrayp, *allocp, AvFILLp(av)+1, SV*); - *maxp += tmp; - *arrayp = *allocp; - if (AvREAL(av)) { - while (tmp) - ary[--tmp] = NULL; - } - if (key > *maxp - 10) { - newmax = key + *maxp; - goto resize; - } - } - else { - if (*allocp) { + SSize_t ary_offset = *maxp + 1; + SSize_t to_null = 0; + SSize_t newmax = 0; + + if (av && *allocp != *arrayp) { /* a shifted SV* array exists */ + to_null = *arrayp - *allocp; + *maxp += to_null; + + Move(*arrayp, *allocp, AvFILLp(av)+1, SV*); + + if (key > *maxp - 10) { + newmax = key + *maxp; + goto resize; + } + } else if (*allocp) { /* a full SV* array exists */ #ifdef Perl_safesysmalloc_size - /* Whilst it would be quite possible to move this logic around - (as I did in the SV code), so as to set AvMAX(av) early, - based on calling Perl_safesysmalloc_size() immediately after - allocation, I'm not convinced that it is a great idea here. - In an array we have to loop round setting everything to - NULL, which means writing to memory, potentially lots - of it, whereas for the SV buffer case we don't touch the - "bonus" memory. So there there is no cost in telling the - world about it, whereas here we have to do work before we can - tell the world about it, and that work involves writing to - memory that might never be read. So, I feel, better to keep - the current lazy system of only writing to it if our caller - has a need for more space. NWC */ - newmax = Perl_safesysmalloc_size((void*)*allocp) / - sizeof(const SV *) - 1; - - if (key <= newmax) - goto resized; + /* Whilst it would be quite possible to move this logic around + (as I did in the SV code), so as to set AvMAX(av) early, + based on calling Perl_safesysmalloc_size() immediately after + allocation, I'm not convinced that it is a great idea here. + In an array we have to loop round setting everything to + NULL, which means writing to memory, potentially lots + of it, whereas for the SV buffer case we don't touch the + "bonus" memory. So there there is no cost in telling the + world about it, whereas here we have to do work before we can + tell the world about it, and that work involves writing to + memory that might never be read. So, I feel, better to keep + the current lazy system of only writing to it if our caller + has a need for more space. NWC */ + newmax = Perl_safesysmalloc_size((void*)*allocp) / + sizeof(const SV *) - 1; + + if (key <= newmax) + goto resized; #endif - /* overflow-safe version of newmax = key + *maxp/5 */ - newmax = *maxp / 5; - newmax = (key > SSize_t_MAX - newmax) - ? 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! */ - MEM_WRAP_CHECK_1(newmax, SV*, oom_array_extend); - } + /* overflow-safe version of newmax = key + *maxp/5 */ + newmax = *maxp / 5; + newmax = (key > SSize_t_MAX - newmax) + ? SSize_t_MAX : key + newmax; + resize: + { + /* 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_s(newmax, SV*, "Out of memory during array extend"); + } #ifdef STRESS_REALLOC - { - SV ** const old_alloc = *allocp; - Newx(*allocp, newmax+1, SV*); - Copy(old_alloc, *allocp, *maxp + 1, SV*); - Safefree(old_alloc); - } + { + SV ** const old_alloc = *allocp; + Newx(*allocp, newmax+1, SV*); + Copy(old_alloc, *allocp, *maxp + 1, SV*); + Safefree(old_alloc); + } #else - Renew(*allocp,newmax+1, SV*); + Renew(*allocp,newmax+1, SV*); #endif #ifdef Perl_safesysmalloc_size - resized: + resized: #endif - ary = *allocp + *maxp + 1; - tmp = newmax - *maxp; - if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */ - PL_stack_sp = *allocp + (PL_stack_sp - PL_stack_base); - PL_stack_base = *allocp; - PL_stack_max = PL_stack_base + newmax; - } - } - 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*/ - MEM_WRAP_CHECK_1(newmax, SV*, oom_array_extend); - } - Newx(*allocp, newmax+1, SV*); - ary = *allocp + 1; - tmp = newmax; - *allocp[0] = NULL; /* For the stacks */ - } - if (av && AvREAL(av)) { - while (tmp) - ary[--tmp] = NULL; - } - - *arrayp = *allocp; - *maxp = newmax; - } + to_null += newmax - *maxp; + *maxp = newmax; + + /* See GH#18014 for discussion of when this might be needed: */ + if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */ + PL_stack_sp = *allocp + (PL_stack_sp - PL_stack_base); + PL_stack_base = *allocp; + PL_stack_max = PL_stack_base + newmax; + } + } else { /* there is no SV* array yet */ + *maxp = key < 3 ? 3 : key; + { + /* see comment above about newmax+1*/ + MEM_WRAP_CHECK_s(*maxp, SV*, + "Out of memory during array extend"); + } + /* Newxz isn't used below because testing showed it to be slower + * than Newx+Zero (also slower than Newx + the previous while + * loop) for small arrays, which are very common in perl. */ + Newx(*allocp, *maxp+1, SV*); + /* Stacks require only the first element to be &PL_sv_undef + * (set elsewhere). However, since non-stack AVs are likely + * to dominate in modern production applications, stacks + * don't get any special treatment here. */ + ary_offset = 0; + to_null = *maxp+1; + goto zero; + } + + if (av && AvREAL(av)) { + zero: + Zero(*allocp + ary_offset,to_null,SV*); + } + + *arrayp = *allocp; } } @@ -210,7 +215,7 @@ value is non-null before dereferencing it to a C. See L 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 */ @@ -288,11 +293,6 @@ Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval) return lval ? av_store(av,key,newSV(0)) : NULL; } - if (UNLIKELY(AvREIFY(av) && SvIS_FREED(AvARRAY(av)[key]))) { - /* eg. @_ could have freed elts */ - AvARRAY(av)[key] = NULL; /* 1/2 reify */ - goto emptyness; - } return &AvARRAY(av)[key]; } @@ -310,7 +310,7 @@ Note that the caller is responsible for suitably incrementing the reference count of C before the call, and decrementing it if the function returned C. -Approximate Perl equivalent: C<$myarray[$key] = $val;>. +Approximate Perl equivalent: C. See L for more information on how to use this function on tied arrays. @@ -406,7 +406,7 @@ Perl equivalent: C AV * Perl_av_make(pTHX_ SSize_t size, SV **strp) { - AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV)); + AV * const av = newAV(); /* sv_upgrade does AvREAL_only() */ PERL_ARGS_ASSERT_AV_MAKE; assert(SvTYPE(av) == SVt_PVAV); @@ -414,13 +414,17 @@ Perl_av_make(pTHX_ SSize_t size, SV **strp) 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; - 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); @@ -435,8 +439,11 @@ Perl_av_make(pTHX_ SSize_t size, SV **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; } @@ -444,7 +451,7 @@ Perl_av_make(pTHX_ SSize_t size, SV **strp) /* =for apidoc av_clear -Frees the all the elements of an array, leaving it empty. +Frees all the elements of an array, leaving it empty. The XS equivalent of C<@array = ()>. See also L. Note that it is possible that the actions of a destructor called directly @@ -462,6 +469,7 @@ Perl_av_clear(pTHX_ AV *av) { SSize_t extra; bool real; + SSize_t orig_ix = 0; PERL_ARGS_ASSERT_AV_CLEAR; assert(SvTYPE(av) == SVt_PVAV); @@ -487,11 +495,15 @@ Perl_av_clear(pTHX_ AV *av) 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; - 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 @@ -506,7 +518,14 @@ Perl_av_clear(pTHX_ AV *av) 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); + } } /* @@ -527,6 +546,7 @@ void 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); @@ -535,10 +555,15 @@ Perl_av_undef(pTHX_ AV *av) 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; - 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]); } @@ -549,7 +574,14 @@ Perl_av_undef(pTHX_ AV *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); + } } /* @@ -578,7 +610,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. -Perl equivalent: C. +Perl equivalent: C. =cut */ @@ -666,10 +698,9 @@ Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val) =for apidoc av_unshift Unshift the given number of C values onto the beginning of the -array. The array will grow automatically to accommodate the addition. You -must then use C to assign values to these new elements. +array. The array will grow automatically to accommodate the addition. -Perl equivalent: S> +Perl equivalent: S> =cut */ @@ -769,21 +800,27 @@ Perl_av_shift(pTHX_ AV *av) } /* -=for apidoc av_top_index +=for apidoc av_tindex +=for apidoc_item av_top_index -Returns the highest index in the array. The number of elements in the -array is S>. Returns -1 if the array is empty. +These behave identically. +If the array C is empty, these return -1; otherwise they return the maximum +value of the indices of all the array elements which are currently defined in +C. -The Perl equivalent for this is C<$#myarray>. +They process 'get' magic. -(A slightly shorter form is C.) +The Perl equivalent for these is C<$#av>. + +Use C> to get the number of elements in an array. =for apidoc av_len Same as L. Note that, unlike what the name implies, it returns -the highest index in the array, so to get the size of the array you need to use -S>. This is unlike L, which returns what you would -expect. +the maximum index in the array. This is unlike L, which returns what +you would expect. + +B>>. =cut */ @@ -853,11 +890,13 @@ Perl_av_fill(pTHX_ AV *av, SSize_t fill) /* =for apidoc av_delete -Deletes the element indexed by C from the array, makes the element mortal, -and returns it. If C equals C, the element is freed and null -is returned. Perl equivalent: S> for the -non-C version and a void-context S> for the -C version. +Deletes the element indexed by C from the array, makes the element +mortal, and returns it. If C equals C, the element is +freed and NULL is returned. NULL is also returned if C is out of +range. + +Perl equivalent: S> (with the +C in void context if C is present). =cut */ @@ -986,6 +1025,9 @@ Perl_av_exists(pTHX_ AV *av, SSize_t 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 @@ -1028,17 +1070,27 @@ Perl_av_iter_p(pTHX_ AV *av) { 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; } /*