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);
nok = TRUE;
}
else if ((numtype & IS_NUMBER_NAN)) {
- nok = TRUE;
SvNV_set(sv, NV_NAN);
+ nok = TRUE;
}
- else if (pok)
+ else if (pok) {
SvNV_set(sv, Atof(SvPVX_const(sv)));
+ /* Purposefully no true nok here, since we don't want to blow
+ * away the possible IOK/UV of an existing sv. */
+ }
if (nok) {
- SvNOK_only(sv); /* No IV or UV please. */
+ SvNOK_only(sv); /* No IV or UV please, this is pure infnan. */
if (pok)
SvPOK_on(sv); /* PV is okay, though. */
}
* 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)) {
}
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
* 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,
new_SV(sv);
if (len) {
- sv_upgrade(sv, SVt_PV);
- SvGROW(sv, len + 1);
+ sv_grow(sv, len + 1);
}
return sv;
}
}
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 */
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;
# 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;
is safe. */
is_utf8 = (bool)va_arg(*args, int);
elen = va_arg(*args, UV);
+ if ((IV)elen < 0) {
+ /* check if utf8 length is larger than 0 when cast to IV */
+ assert( (IV)elen >= 0 ); /* in DEBUGGING build we want to crash */
+ elen= 0; /* otherwise we want to treat this as an empty string */
+ }
eptr = va_arg(*args, char *);
q += sizeof(UTF8f)-1;
goto string;
}
}
- 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
}
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:
https://perl5.git.perl.org / perl5.git / blobdiff