PERL_UNUSED_RESULT(Gconvert((NV)(nv), (int)ndig, 0, buffer))
#endif
-#ifdef PERL_NEW_COPY_ON_WRITE
-# ifndef SV_COW_THRESHOLD
+#ifndef SV_COW_THRESHOLD
# define SV_COW_THRESHOLD 0 /* COW iff len > K */
-# endif
-# ifndef SV_COWBUF_THRESHOLD
+#endif
+#ifndef SV_COWBUF_THRESHOLD
# define SV_COWBUF_THRESHOLD 1250 /* COW iff len > K */
-# endif
-# ifndef SV_COW_MAX_WASTE_THRESHOLD
+#endif
+#ifndef SV_COW_MAX_WASTE_THRESHOLD
# define SV_COW_MAX_WASTE_THRESHOLD 80 /* COW iff (len - cur) < K */
-# endif
-# ifndef SV_COWBUF_WASTE_THRESHOLD
+#endif
+#ifndef SV_COWBUF_WASTE_THRESHOLD
# define SV_COWBUF_WASTE_THRESHOLD 80 /* COW iff (len - cur) < K */
-# endif
-# ifndef SV_COW_MAX_WASTE_FACTOR_THRESHOLD
+#endif
+#ifndef SV_COW_MAX_WASTE_FACTOR_THRESHOLD
# define SV_COW_MAX_WASTE_FACTOR_THRESHOLD 2 /* COW iff len < (cur * K) */
-# endif
-# ifndef SV_COWBUF_WASTE_FACTOR_THRESHOLD
+#endif
+#ifndef SV_COWBUF_WASTE_FACTOR_THRESHOLD
# define SV_COWBUF_WASTE_FACTOR_THRESHOLD 2 /* COW iff len < (cur * K) */
-# endif
#endif
/* Work around compiler warnings about unsigned >= THRESHOLD when thres-
hold is 0. */
This is the same trick as was used for NV and IV bodies. Ironically it
doesn't need to be used for NV bodies any more, because NV is now at
-the start of the structure. IV bodies don't need it either, because
-they are no longer allocated.
+the start of the structure. IV bodies, and also in some builds NV bodies,
+don't need it either, because they are no longer allocated.
In turn, the new_body_* allocators call S_new_body(), which invokes
new_body_inline macro, which takes a lock, and takes a body off the
struct body_details {
U8 body_size; /* Size to allocate */
U8 copy; /* Size of structure to copy (may be shorter) */
- U8 offset;
- unsigned int type : 4; /* We have space for a sanity check. */
- unsigned int cant_upgrade : 1; /* Cannot upgrade this type */
- unsigned int zero_nv : 1; /* zero the NV when upgrading from this */
- unsigned int arena : 1; /* Allocated from an arena */
- size_t arena_size; /* Size of arena to allocate */
+ U8 offset; /* Size of unalloced ghost fields to first alloced field*/
+ PERL_BITFIELD8 type : 4; /* We have space for a sanity check. */
+ PERL_BITFIELD8 cant_upgrade : 1;/* Cannot upgrade this type */
+ PERL_BITFIELD8 zero_nv : 1; /* zero the NV when upgrading from this */
+ PERL_BITFIELD8 arena : 1; /* Allocated from an arena */
+ U32 arena_size; /* Size of arena to allocate */
};
#define HADNV FALSE
? count * body_size \
: FIT_ARENA0 (body_size)
#define FIT_ARENA(count,body_size) \
- count \
+ (U32)(count \
? FIT_ARENAn (count, body_size) \
- : FIT_ARENA0 (body_size)
+ : FIT_ARENA0 (body_size))
/* Calculate the length to copy. Specifically work out the length less any
final padding the compiler needed to add. See the comment in sv_upgrade
NOARENA /* IVS don't need an arena */, 0
},
+#if NVSIZE <= IVSIZE
+ { 0, sizeof(NV),
+ STRUCT_OFFSET(XPVNV, xnv_u),
+ SVt_NV, FALSE, HADNV, NOARENA, 0 },
+#else
{ sizeof(NV), sizeof(NV),
STRUCT_OFFSET(XPVNV, xnv_u),
SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
+#endif
{ sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
} STMT_END
#ifdef PURIFY
-
-#define new_XNV() safemalloc(sizeof(XPVNV))
+#if !(NVSIZE <= IVSIZE)
+# define new_XNV() safemalloc(sizeof(XPVNV))
+#endif
#define new_XPVNV() safemalloc(sizeof(XPVNV))
#define new_XPVMG() safemalloc(sizeof(XPVMG))
#else /* !PURIFY */
-#define new_XNV() new_body_allocated(SVt_NV)
+#if !(NVSIZE <= IVSIZE)
+# define new_XNV() new_body_allocated(SVt_NV)
+#endif
#define new_XPVNV() new_body_allocated(SVt_PVNV)
#define new_XPVMG() new_body_allocated(SVt_PVMG)
return;
case SVt_NV:
assert(old_type == SVt_NULL);
+#if NVSIZE <= IVSIZE
+ SvANY(sv) = (XPVNV*)((char*)&(sv->sv_u.svu_nv) - STRUCT_OFFSET(XPVNV, xnv_u.xnv_nv));
+#else
SvANY(sv) = new_XNV();
+#endif
SvNV_set(sv, 0);
return;
case SVt_PVHV:
(unsigned long)new_type);
}
- if (old_type > SVt_IV) {
+ /* if this is zero, this is a body-less SVt_NULL, SVt_IV/SVt_RV,
+ and sometimes SVt_NV */
+ if (old_type_details->body_size) {
#ifdef PURIFY
safefree(old_body);
#else
static void
S_sv_setnv(pTHX_ SV* sv, int numtype)
{
- bool pok = SvPOK(sv);
+ bool pok = cBOOL(SvPOK(sv));
bool nok = FALSE;
if ((numtype & IS_NUMBER_INFINITY)) {
SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF);
* IV or UV at same time to avoid this. */
/* IV-over-UV optimisation - choose to cache IV if possible */
- if (Perl_isinfnan(SvNVX(sv)))
+ if (UNLIKELY(Perl_isinfnan(SvNVX(sv))))
return FALSE;
if (SvTYPE(sv) == SVt_NV)
if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
mg_get(sv);
- if (SvNOK(sv) && Perl_isinfnan(SvNVX(sv)))
+ if (SvNOK(sv) && UNLIKELY(Perl_isinfnan(SvNVX(sv))))
return 0; /* So wrong but what can we do. */
if (SvROK(sv)) {
if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
mg_get(sv);
- if (SvNOK(sv) && Perl_isinfnan(SvNVX(sv)))
+ if (SvNOK(sv) && UNLIKELY(Perl_isinfnan(SvNVX(sv))))
return 0; /* So wrong but what can we do. */
if (SvROK(sv)) {
return;
}
-static void
-S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
+void
+Perl_gv_setref(pTHX_ SV *const dstr, SV *const sstr)
{
SV * const sref = SvRV(sstr);
SV *dref;
U8 import_flag = 0;
const U32 stype = SvTYPE(sref);
- PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
+ PERL_ARGS_ASSERT_GV_SETREF;
if (intro) {
GvINTRO_off(dstr); /* one-shot flag */
}
if (import_flag == GVf_IMPORTED_SV) {
if (intro) {
- dSS_ADD;
- SS_ADD_PTR(gp_ref(GvGP(dstr)));
- SS_ADD_UV(SAVEt_GP_ALIASED_SV
- | cBOOL(GvALIASED_SV(dstr)) << 8);
- SS_ADD_END(2);
+ save_aliased_sv((GV *)dstr);
}
/* Turn off the flag if sref is not referenced elsewhere,
even by weak refs. (SvRMAGICAL is a pessimistic check for
Perl_magic_clearisa(aTHX_ NULL, mg);
}
else if (stype == SVt_PVIO) {
- DEBUG_o(Perl_deb(aTHX_ "glob_assign_ref clearing PL_stashcache\n"));
+ DEBUG_o(Perl_deb(aTHX_ "gv_setref clearing PL_stashcache\n"));
/* It's a cache. It will rebuild itself quite happily.
It's a lot of effort to work out exactly which key (or keys)
might be invalidated by the creation of the this file handle.
if (dtype >= SVt_PV) {
if (isGV_with_GP(dstr)) {
- glob_assign_ref(dstr, sstr);
+ gv_setref(dstr, sstr);
return;
}
if (SvPVX_const(dstr)) {
* be allocated it is still not worth swiping PADTMPs for short
* strings, as the savings here are small.
*
- * If the rhs is already flagged as a copy-on-write string and COW
- * is possible here, we use copy-on-write and make both SVs share
- * the string buffer.
- *
- * If the rhs is not flagged as copy-on-write, then we see whether
- * it is worth upgrading it to such. If the lhs already has a buf-
+ * If swiping is not an option, then we see whether it is
+ * worth using copy-on-write. If the lhs already has a buf-
* fer big enough and the string is short, we skip it and fall back
* to method 3, since memcpy is faster for short strings than the
* later bookkeeping overhead that copy-on-write entails.
+
+ * If the rhs is not a copy-on-write string yet, then we also
+ * consider whether the buffer is too large relative to the string
+ * it holds. Some operations such as readline allocate a large
+ * buffer in the expectation of reusing it. But turning such into
+ * a COW buffer is counter-productive because it increases memory
+ * usage by making readline allocate a new large buffer the sec-
+ * ond time round. So, if the buffer is too large, again, we use
+ * method 3 (copy).
*
- * If there is no buffer on the left, or the buffer is too small,
- * then we use copy-on-write.
+ * Finally, if there is no buffer on the left, or the buffer is too
+ * small, then we use copy-on-write and make both SVs share the
+ * string buffer.
+ *
*/
/* Whichever path we take through the next code, we want this true,
=for apidoc sv_catpvn_flags
Concatenates the string onto the end of the string which is in the SV. The
-C<len> indicates number of bytes to copy. If the SV has the UTF-8
-status set, then the bytes appended should be valid UTF-8.
+C<len> indicates number of bytes to copy.
+
+By default, the string appended is assumed to be valid UTF-8 if the SV has
+the UTF-8 status set, and a string of bytes otherwise. One can force the
+appended string to be interpreted as UTF-8 by supplying the C<SV_CATUTF8>
+flag, and as bytes by supplying the C<SV_CATBYTES> flag; the SV or the
+string appended will be upgraded to UTF-8 if necessary.
+
If C<flags> has the C<SV_SMAGIC> bit set, will
C<mg_set> on C<dsv> afterwards if appropriate.
C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
if (ssv) {
STRLEN slen;
const char *spv = SvPV_flags_const(ssv, slen, flags);
- if (spv) {
- if (flags & SV_GMAGIC)
+ if (flags & SV_GMAGIC)
SvGETMAGIC(dsv);
- sv_catpvn_flags(dsv, spv, slen,
+ sv_catpvn_flags(dsv, spv, slen,
DO_UTF8(ssv) ? SV_CATUTF8 : SV_CATBYTES);
- if (flags & SV_SMAGIC)
+ if (flags & SV_SMAGIC)
SvSETMAGIC(dsv);
- }
}
}
new_SV(sv);
if (len) {
- sv_upgrade(sv, SVt_PV);
- SvGROW(sv, len + 1);
+ sv_grow(sv, len + 1);
}
return sv;
}
float b, c, keep_earlier;
if (byte > cache[3]) {
/* New position is between the existing pair of pairs. */
- b = cache[3];
- c = byte;
+ b = (float)cache[3];
+ c = (float)byte;
} else {
/* New position is before the existing pair of pairs. */
- b = byte;
- c = cache[3];
+ b = (float)byte;
+ c = (float)cache[3];
}
keep_earlier = THREEWAY_SQUARE(0, b, c, blen);
if (byte > cache[3]) {
}
if (flags & SVp_NOK) {
const NV was = SvNVX(sv);
- if (!Perl_isinfnan(was) &&
+ if (LIKELY(!Perl_isinfnan(was)) &&
NV_OVERFLOWS_INTEGERS_AT &&
was >= NV_OVERFLOWS_INTEGERS_AT) {
/* diag_listed_as: Lost precision when %s %f by 1 */
oops_its_num:
{
const NV was = SvNVX(sv);
- if (!Perl_isinfnan(was) &&
+ if (LIKELY(!Perl_isinfnan(was)) &&
NV_OVERFLOWS_INTEGERS_AT &&
was <= -NV_OVERFLOWS_INTEGERS_AT) {
/* diag_listed_as: Lost precision when %s %f by 1 */
*/
#define PUSH_EXTEND_MORTAL__SV_C(AnSv) \
STMT_START { \
- EXTEND_MORTAL(1); \
- PL_tmps_stack[++PL_tmps_ix] = (AnSv); \
+ SSize_t ix = ++PL_tmps_ix; \
+ if (UNLIKELY(ix >= PL_tmps_max)) \
+ ix = tmps_grow_p(ix); \
+ PL_tmps_stack[ix] = (AnSv); \
} STMT_END
/*
{
dVAR;
if (!sv)
- return NULL;
+ return sv;
if (SvIMMORTAL(sv))
return sv;
PUSH_EXTEND_MORTAL__SV_C(sv);
SV *sv;
new_SV(sv);
- sv_upgrade(sv, type);
+ ASSUME(SvTYPE(sv) == SVt_FIRST);
+ if(type != SVt_FIRST)
+ sv_upgrade(sv, type);
return sv;
}
PERL_ARGS_ASSERT_F0CONVERT;
- if (Perl_isinfnan(nv)) {
+ if (UNLIKELY(Perl_isinfnan(nv))) {
STRLEN n = S_infnan_2pv(nv, endbuf - *len, *len);
*len = n;
return endbuf - n;
#if LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN || \
LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN
# define LONGDOUBLE_DOUBLEDOUBLE
-# define DOUBLEDOUBLE_MAXBITS 1028
+/* The first double can be as large as 2**1023, or '1' x '0' x 1023.
+ * The second double can be as small as 2**-1074, or '0' x 1073 . '1'.
+ * The sum of them can be '1' . '0' x 2096 . '1', with implied radix point
+ * after the first 1023 zero bits. */
+# define DOUBLEDOUBLE_MAXBITS 2098
#endif
/* vhex will contain the values (0..15) of the hex digits ("nybbles"
* of 4 bits); 1 for the implicit 1, and the mantissa bits, four bits
- * per xdigit. */
+ * per xdigit. For the double-double case, this can be rather many. */
#ifdef LONGDOUBLE_DOUBLEDOUBLE
# define VHEX_SIZE (1+DOUBLEDOUBLE_MAXBITS/4)
#else
if (vend) *v++ = ((nv) == 0.0) ? 0 : 1; else v++; \
} STMT_END
-#ifdef LONGDOUBLE_DOUBLEDOUBLE
-# define HEXTRACTSIZE (DOUBLEDOUBLE_MAXBITS/8)
+ /* HEXTRACTSIZE is the maximum number of xdigits. */
+#if defined(USE_LONG_DOUBLE) && defined(LONGDOUBLE_DOUBLEDOUBLE)
+# define HEXTRACTSIZE (DOUBLEDOUBLE_MAXBITS/4)
#else
-# define HEXTRACTSIZE NVSIZE
+# define HEXTRACTSIZE 2 * NVSIZE
#endif
const U8* nvp = (const U8*)(&nv);
- const U8* vmaxend = vhex + 2 * HEXTRACTSIZE + 1;
+ const U8* vmaxend = vhex + HEXTRACTSIZE;
(void)Perl_frexp(PERL_ABS(nv), exponent);
if (vend && (vend <= vhex || vend > vmaxend))
Perl_croak(aTHX_ "Hexadecimal float: internal error");
}
# else
HEXTRACT_LO_NYBBLE(1);
- for (ix = 2; ix < HEXTRACTSIZE; ix++) {
+ for (ix = 2; ix < NVSIZE; ix++) {
HEXTRACT_BYTE(ix);
}
# endif
/* For double-double the ixmin and ixmax stay at zero,
* which is convenient since the HEXTRACTSIZE is tricky
* for double-double. */
- ixmin < 0 || ixmax >= HEXTRACTSIZE ||
+ ixmin < 0 || ixmax >= NVSIZE ||
(vend && v != vend))
Perl_croak(aTHX_ "Hexadecimal float: internal error");
return v;
# define FV_GF PERL_PRIgldbl
# if defined(__VMS) && defined(__ia64) && defined(__IEEE_FLOAT)
/* Work around breakage in OTS$CVT_FLOAT_T_X */
-# define NV_TO_FV(nvsv) (Perl_isnan(SvNV(nvsv)) ? LDBL_SNAN : SvNV(nvsv));
+# define NV_TO_FV(nv,fv) STMT_START { \
+ double _dv = nv; \
+ fv = Perl_isnan(_dv) ? LDBL_QNAN : _dv; \
+ } STMT_END
# else
-# define NV_TO_FV SvNV
+# define NV_TO_FV(nv,fv) (fv)=(nv)
# endif
#else
NV fv;
# define FV_ISFINITE(x) Perl_isfinite((NV)(x))
# define FV_GF NVgf
-# define NV_TO_FV SvNV
+# define NV_TO_FV(nv,fv) (fv)=(nv)
#endif
STRLEN have;
STRLEN need;
}
}
- if (argsv && SvNOK(argsv)) {
+ if (argsv && strchr("BbcDdiOopuUXx",*q)) {
/* XXX va_arg(*args) case? need peek, use va_copy? */
- infnan = Perl_isinfnan(SvNV(argsv));
+ SvGETMAGIC(argsv);
+ infnan = UNLIKELY(isinfnansv(argsv));
}
switch (c = *q++) {
if (infnan)
Perl_croak(aTHX_ "Cannot printf %"NVgf" with '%c'",
/* no va_arg() case */
- SvNV(argsv), (int)c);
- uv = (args) ? va_arg(*args, int) : SvIV(argsv);
+ SvNV_nomg(argsv), (int)c);
+ uv = (args) ? va_arg(*args, int) : SvIV_nomg(argsv);
if ((uv > 255 ||
(!UVCHR_IS_INVARIANT(uv) && SvUTF8(sv)))
&& !IN_BYTES) {
case 'p':
if (infnan) {
- c = 'g';
goto floating_point;
}
if (alt || vectorize)
case 'd':
case 'i':
if (infnan) {
- c = 'g';
goto floating_point;
}
if (vectorize) {
}
}
else {
- IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
+ IV tiv = SvIV_nomg(argsv); /* work around GCC bug #13488 */
switch (intsize) {
case 'c': iv = (char)tiv; break;
case 'h': iv = (short)tiv; break;
uns_integer:
if (infnan) {
- c = 'g';
goto floating_point;
}
if (vectorize) {
}
}
else {
- UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
+ UV tuv = SvUV_nomg(argsv); /* work around GCC bug #13488 */
switch (intsize) {
case 'c': uv = (unsigned char)tuv; break;
case 'h': uv = (unsigned short)tuv; break;
fv = intsize == 'q' ?
va_arg(*args, NV) : va_arg(*args, double);
#elif LONG_DOUBLESIZE > DOUBLESIZE
- fv = intsize == 'q' ?
- va_arg(*args, long double) : va_arg(*args, double);
+ if (intsize == 'q')
+ fv = va_arg(*args, long double);
+ else
+ NV_TO_FV(va_arg(*args, double), fv);
#else
fv = va_arg(*args, double);
#endif
}
else
- fv = NV_TO_FV(argsv);
+ {
+ if (!infnan) SvGETMAGIC(argsv);
+ NV_TO_FV(SvNV_nomg(argsv), fv);
+ }
need = 0;
/* frexp() (or frexpl) has some unspecified behaviour for
* Since each double has their own exponent, the
* doubles may float (haha) rather far from each
* other, and the number of required bits is much
- * larger, up to total of 1028 bits. (NOTE: this
- * is not actually implemented properly yet,
- * we are using just the first double, see
- * S_hextract() for details. But let's prepare
- * for the future.) */
-
- /* 2 hexdigits for each byte. */
+ * larger, up to total of DOUBLEDOUBLE_MAXBITS bits.
+ * See the definition of DOUBLEDOUBLE_MAXBITS.
+ *
+ * Need 2 hexdigits for each byte. */
need += (DOUBLEDOUBLE_MAXBITS/8 + 1) * 2;
/* the size for the exponent already added */
#endif
}
break;
case SVt_NV:
+#if NVSIZE <= IVSIZE
+ SvANY(dstr) = (XPVNV*)((char*)&(dstr->sv_u.svu_nv) - STRUCT_OFFSET(XPVNV, xnv_u.xnv_nv));
+#else
SvANY(dstr) = new_XNV();
+#endif
SvNV_set(dstr, SvNVX(sstr));
break;
default:
PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
+ Copy(proto_perl->IDBcontrol, PL_DBcontrol, DBVARMG_COUNT, IV);
/* symbol tables */
PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
break;
- return varname(gv, hash ? '%' : '@', obase->op_targ,
+ return varname(gv, (char)(hash ? '%' : '@'), obase->op_targ,
keysv, index, subscript_type);
}
if (match)
break;
return varname(gv,
- (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
- ? '@' : '%',
+ (char)((o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
+ ? '@' : '%'),
o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
}
NOT_REACHED; /* NOTREACHED */
{
if (PL_op) {
SV* varname = NULL;
+ const char *desc;
if (uninit_sv && PL_curpad) {
varname = find_uninit_var(PL_op, uninit_sv,0);
if (varname)
sv_insert(varname, 0, 0, " ", 1);
}
+ desc = PL_op->op_type == OP_STRINGIFY && PL_op->op_folded
+ ? "join or string"
+ : OP_DESC(PL_op);
/* PL_warn_uninit_sv is constant */
GCC_DIAG_IGNORE(-Wformat-nonliteral);
/* diag_listed_as: Use of uninitialized value%s */
Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit_sv,
SVfARG(varname ? varname : &PL_sv_no),
- " in ", OP_DESC(PL_op));
+ " in ", desc);
GCC_DIAG_RESTORE;
}
else {
https://perl5.git.perl.org / perl5.git / blobdiff