Line data Source code
1 : /* sv_inline.h
2 : *
3 : * Copyright (C) 2022 by Larry Wall and others
4 : *
5 : * You may distribute under the terms of either the GNU General Public
6 : * License or the Artistic License, as specified in the README file.
7 : *
8 : */
9 :
10 : /* This file contains the newSV_type and newSV_type_mortal functions, as well as
11 : * the various struct and macro definitions they require. In the main, these
12 : * definitions were moved from sv.c, where many of them continue to also be used.
13 : * (In Perl_more_bodies, Perl_sv_upgrade and Perl_sv_clear, for example.) Code
14 : * comments associated with definitions and functions were also copied across
15 : * verbatim.
16 : *
17 : * The rationale for having these as inline functions, rather than in sv.c, is
18 : * that the target type is very often known at compile time, and therefore
19 : * optimum code can be emitted by the compiler, rather than having all calls
20 : * traverse the many branches of Perl_sv_upgrade at runtime.
21 : */
22 :
23 : /* This definition came from perl.h*/
24 :
25 : /* The old value was hard coded at 1008. (4096-16) seems to be a bit faster,
26 : at least on FreeBSD. YMMV, so experiment. */
27 : #ifndef PERL_ARENA_SIZE
28 : #define PERL_ARENA_SIZE 4080
29 : #endif
30 :
31 : /* All other pre-existing definitions and functions that were moved into this
32 : * file originally came from sv.c. */
33 :
34 : #ifdef PERL_POISON
35 : # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
36 : # define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val))
37 : /* Whilst I'd love to do this, it seems that things like to check on
38 : unreferenced scalars
39 : # define POISON_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV)
40 : */
41 : # define POISON_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \
42 : PoisonNew(&SvREFCNT(sv), 1, U32)
43 : #else
44 : # define SvARENA_CHAIN(sv) SvANY(sv)
45 : # define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val)
46 : # define POISON_SV_HEAD(sv)
47 : #endif
48 :
49 : #ifdef PERL_MEM_LOG
50 : # define MEM_LOG_NEW_SV(sv, file, line, func) \
51 : Perl_mem_log_new_sv(sv, file, line, func)
52 : # define MEM_LOG_DEL_SV(sv, file, line, func) \
53 : Perl_mem_log_del_sv(sv, file, line, func)
54 : #else
55 : # define MEM_LOG_NEW_SV(sv, file, line, func) NOOP
56 : # define MEM_LOG_DEL_SV(sv, file, line, func) NOOP
57 : #endif
58 :
59 : #define uproot_SV(p) \
60 : STMT_START { \
61 : (p) = PL_sv_root; \
62 : PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \
63 : ++PL_sv_count; \
64 : } STMT_END
65 :
66 : /* Perl_more_sv lives in sv.c, we don't want to inline it.
67 : * but the function declaration seems to be needed. */
68 : SV* Perl_more_sv(pTHX);
69 :
70 : /* new_SV(): return a new, empty SV head */
71 :
72 : #ifdef DEBUG_LEAKING_SCALARS
73 : /* provide a real function for a debugger to play with */
74 : STATIC SV*
75 : S_new_SV(pTHX_ const char *file, int line, const char *func)
76 : {
77 : SV* sv;
78 :
79 : if (PL_sv_root)
80 : uproot_SV(sv);
81 : else
82 : sv = Perl_more_sv(aTHX);
83 : SvANY(sv) = 0;
84 : SvREFCNT(sv) = 1;
85 : SvFLAGS(sv) = 0;
86 : sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
87 : sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
88 : ? PL_parser->copline
89 : : PL_curcop
90 : ? CopLINE(PL_curcop)
91 : : 0
92 : );
93 : sv->sv_debug_inpad = 0;
94 : sv->sv_debug_parent = NULL;
95 : sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
96 :
97 : sv->sv_debug_serial = PL_sv_serial++;
98 :
99 : MEM_LOG_NEW_SV(sv, file, line, func);
100 : DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) new_SV (from %s:%d [%s])\n",
101 : PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
102 :
103 : return sv;
104 : }
105 : # define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
106 :
107 : #else
108 : # define new_SV(p) \
109 : STMT_START { \
110 : if (PL_sv_root) \
111 : uproot_SV(p); \
112 : else \
113 : (p) = Perl_more_sv(aTHX); \
114 : SvANY(p) = 0; \
115 : SvREFCNT(p) = 1; \
116 : SvFLAGS(p) = 0; \
117 : MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \
118 : } STMT_END
119 : #endif
120 :
121 :
122 : typedef struct xpvhv_with_aux XPVHV_WITH_AUX;
123 :
124 : struct body_details {
125 : U8 body_size; /* Size to allocate */
126 : U8 copy; /* Size of structure to copy (may be shorter) */
127 : U8 offset; /* Size of unalloced ghost fields to first alloced field*/
128 : PERL_BITFIELD8 type : 5; /* We have space for a sanity check. */
129 : PERL_BITFIELD8 cant_upgrade : 1;/* Cannot upgrade this type */
130 : PERL_BITFIELD8 zero_nv : 1; /* zero the NV when upgrading from this */
131 : PERL_BITFIELD8 arena : 1; /* Allocated from an arena */
132 : U32 arena_size; /* Size of arena to allocate */
133 : };
134 :
135 : #define ALIGNED_TYPE_NAME(name) name##_aligned
136 : #define ALIGNED_TYPE(name) \
137 : typedef union { \
138 : name align_me; \
139 : NV nv; \
140 : IV iv; \
141 : } ALIGNED_TYPE_NAME(name)
142 :
143 : ALIGNED_TYPE(regexp);
144 : ALIGNED_TYPE(XPVGV);
145 : ALIGNED_TYPE(XPVLV);
146 : ALIGNED_TYPE(XPVAV);
147 : ALIGNED_TYPE(XPVHV);
148 : ALIGNED_TYPE(XPVHV_WITH_AUX);
149 : ALIGNED_TYPE(XPVCV);
150 : ALIGNED_TYPE(XPVFM);
151 : ALIGNED_TYPE(XPVIO);
152 : ALIGNED_TYPE(XPVOBJ);
153 :
154 : #define HADNV FALSE
155 : #define NONV TRUE
156 :
157 :
158 : #ifdef PURIFY
159 : /* With -DPURFIY we allocate everything directly, and don't use arenas.
160 : This seems a rather elegant way to simplify some of the code below. */
161 : #define HASARENA FALSE
162 : #else
163 : #define HASARENA TRUE
164 : #endif
165 : #define NOARENA FALSE
166 :
167 : /* Size the arenas to exactly fit a given number of bodies. A count
168 : of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
169 : simplifying the default. If count > 0, the arena is sized to fit
170 : only that many bodies, allowing arenas to be used for large, rare
171 : bodies (XPVFM, XPVIO) without undue waste. The arena size is
172 : limited by PERL_ARENA_SIZE, so we can safely oversize the
173 : declarations.
174 : */
175 : #define FIT_ARENA0(body_size) \
176 : ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
177 : #define FIT_ARENAn(count,body_size) \
178 : ( count * body_size <= PERL_ARENA_SIZE) \
179 : ? count * body_size \
180 : : FIT_ARENA0 (body_size)
181 : #define FIT_ARENA(count,body_size) \
182 : (U32)(count \
183 : ? FIT_ARENAn (count, body_size) \
184 : : FIT_ARENA0 (body_size))
185 :
186 : /* Calculate the length to copy. Specifically work out the length less any
187 : final padding the compiler needed to add. See the comment in sv_upgrade
188 : for why copying the padding proved to be a bug. */
189 :
190 : #define copy_length(type, last_member) \
191 : STRUCT_OFFSET(type, last_member) \
192 : + sizeof (((type*)SvANY((const SV *)0))->last_member)
193 :
194 : static const struct body_details bodies_by_type[] = {
195 : /* HEs use this offset for their arena. */
196 : { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
197 :
198 : /* IVs are in the head, so the allocation size is 0. */
199 : { 0,
200 : sizeof(IV), /* This is used to copy out the IV body. */
201 : STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
202 : NOARENA /* IVS don't need an arena */, 0
203 : },
204 :
205 : #if NVSIZE <= IVSIZE
206 : { 0, sizeof(NV),
207 : STRUCT_OFFSET(XPVNV, xnv_u),
208 : SVt_NV, FALSE, HADNV, NOARENA, 0 },
209 : #else
210 : { sizeof(NV), sizeof(NV),
211 : STRUCT_OFFSET(XPVNV, xnv_u),
212 : SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
213 : #endif
214 :
215 : { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
216 : copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
217 : + STRUCT_OFFSET(XPV, xpv_cur),
218 : SVt_PV, FALSE, NONV, HASARENA,
219 : FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
220 :
221 : { sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur),
222 : copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur),
223 : + STRUCT_OFFSET(XPV, xpv_cur),
224 : SVt_INVLIST, TRUE, NONV, HASARENA,
225 : FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)) },
226 :
227 : { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
228 : copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
229 : + STRUCT_OFFSET(XPV, xpv_cur),
230 : SVt_PVIV, FALSE, NONV, HASARENA,
231 : FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
232 :
233 : #if NVSIZE > 8 && PTRSIZE < 8 && MEM_ALIGNBYTES > 8
234 : /* NV may need strict 16 byte alignment.
235 :
236 : On 64-bit systems the NV ends up aligned despite the hack
237 : avoiding allocation of xmg_stash and xmg_u, so only do this
238 : for 32-bit systems.
239 : */
240 : { sizeof(XPVNV),
241 : sizeof(XPVNV),
242 : 0,
243 : SVt_PVNV, FALSE, HADNV, HASARENA,
244 : FIT_ARENA(0, sizeof(XPVNV)) },
245 : #else
246 : { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
247 : copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
248 : + STRUCT_OFFSET(XPV, xpv_cur),
249 : SVt_PVNV, FALSE, HADNV, HASARENA,
250 : FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
251 : #endif
252 : { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
253 : HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
254 :
255 : { sizeof(ALIGNED_TYPE_NAME(regexp)),
256 : sizeof(regexp),
257 : 0,
258 : SVt_REGEXP, TRUE, NONV, HASARENA,
259 : FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(regexp)))
260 : },
261 :
262 : { sizeof(ALIGNED_TYPE_NAME(XPVGV)), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
263 : HASARENA, FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVGV))) },
264 :
265 : { sizeof(ALIGNED_TYPE_NAME(XPVLV)), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
266 : HASARENA, FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVLV))) },
267 :
268 : { sizeof(ALIGNED_TYPE_NAME(XPVAV)),
269 : copy_length(XPVAV, xav_alloc),
270 : 0,
271 : SVt_PVAV, TRUE, NONV, HASARENA,
272 : FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVAV))) },
273 :
274 : { sizeof(ALIGNED_TYPE_NAME(XPVHV)),
275 : copy_length(XPVHV, xhv_max),
276 : 0,
277 : SVt_PVHV, TRUE, NONV, HASARENA,
278 : FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVHV))) },
279 :
280 : { sizeof(ALIGNED_TYPE_NAME(XPVCV)),
281 : sizeof(XPVCV),
282 : 0,
283 : SVt_PVCV, TRUE, NONV, HASARENA,
284 : FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVCV))) },
285 :
286 : { sizeof(ALIGNED_TYPE_NAME(XPVFM)),
287 : sizeof(XPVFM),
288 : 0,
289 : SVt_PVFM, TRUE, NONV, NOARENA,
290 : FIT_ARENA(20, sizeof(ALIGNED_TYPE_NAME(XPVFM))) },
291 :
292 : { sizeof(ALIGNED_TYPE_NAME(XPVIO)),
293 : sizeof(XPVIO),
294 : 0,
295 : SVt_PVIO, TRUE, NONV, HASARENA,
296 : FIT_ARENA(24, sizeof(ALIGNED_TYPE_NAME(XPVIO))) },
297 :
298 : { sizeof(ALIGNED_TYPE_NAME(XPVOBJ)),
299 : copy_length(XPVOBJ, xobject_fields),
300 : 0,
301 : SVt_PVOBJ, TRUE, NONV, HASARENA,
302 : FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVOBJ))) },
303 : };
304 :
305 : #define new_body_allocated(sv_type) \
306 : (void *)((char *)S_new_body(aTHX_ sv_type) \
307 : - bodies_by_type[sv_type].offset)
308 :
309 : #ifdef PURIFY
310 : #if !(NVSIZE <= IVSIZE)
311 : # define new_XNV() safemalloc(sizeof(XPVNV))
312 : #endif
313 : #define new_XPVNV() safemalloc(sizeof(XPVNV))
314 : #define new_XPVMG() safemalloc(sizeof(XPVMG))
315 :
316 : #define del_body_by_type(p, type) safefree(p)
317 :
318 : #else /* !PURIFY */
319 :
320 : #if !(NVSIZE <= IVSIZE)
321 : # define new_XNV() new_body_allocated(SVt_NV)
322 : #endif
323 : #define new_XPVNV() new_body_allocated(SVt_PVNV)
324 : #define new_XPVMG() new_body_allocated(SVt_PVMG)
325 :
326 : #define del_body_by_type(p, type) \
327 : del_body(p + bodies_by_type[(type)].offset, \
328 : &PL_body_roots[(type)])
329 :
330 : #endif /* PURIFY */
331 :
332 : /* no arena for you! */
333 :
334 : #define new_NOARENA(details) \
335 : safemalloc((details)->body_size + (details)->offset)
336 : #define new_NOARENAZ(details) \
337 : safecalloc((details)->body_size + (details)->offset, 1)
338 :
339 : #ifndef PURIFY
340 :
341 : /* grab a new thing from the arena's free list, allocating more if necessary. */
342 : #define new_body_from_arena(xpv, root_index, type_meta) \
343 : STMT_START { \
344 : void ** const r3wt = &PL_body_roots[root_index]; \
345 : xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \
346 : ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ root_index, \
347 : type_meta.body_size,\
348 : type_meta.arena_size)); \
349 : *(r3wt) = *(void**)(xpv); \
350 : } STMT_END
351 :
352 : PERL_STATIC_INLINE void *
353 645 : S_new_body(pTHX_ const svtype sv_type)
354 : {
355 : void *xpv;
356 645 : new_body_from_arena(xpv, sv_type, bodies_by_type[sv_type]);
357 645 : return xpv;
358 : }
359 :
360 : #endif
361 :
362 : static const struct body_details fake_rv =
363 : { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
364 :
365 : static const struct body_details fake_hv_with_aux =
366 : /* The SVt_IV arena is used for (larger) PVHV bodies. */
367 : { sizeof(ALIGNED_TYPE_NAME(XPVHV_WITH_AUX)),
368 : copy_length(XPVHV, xhv_max),
369 : 0,
370 : SVt_PVHV, TRUE, NONV, HASARENA,
371 : FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVHV_WITH_AUX))) };
372 :
373 : /*
374 : =for apidoc newSV_type
375 :
376 : Creates a new SV, of the type specified. The reference count for the new SV
377 : is set to 1.
378 :
379 : =cut
380 : */
381 :
382 : PERL_STATIC_INLINE SV *
383 1244 : Perl_newSV_type(pTHX_ const svtype type)
384 : {
385 : SV *sv;
386 : void* new_body;
387 : const struct body_details *type_details;
388 :
389 1244 : new_SV(sv);
390 :
391 1244 : type_details = bodies_by_type + type;
392 :
393 1244 : SvFLAGS(sv) &= ~SVTYPEMASK;
394 1244 : SvFLAGS(sv) |= type;
395 :
396 1244 : switch (type) {
397 0 : case SVt_NULL:
398 0 : break;
399 599 : case SVt_IV:
400 599 : SET_SVANY_FOR_BODYLESS_IV(sv);
401 599 : SvIV_set(sv, 0);
402 599 : break;
403 0 : case SVt_NV:
404 : #if NVSIZE <= IVSIZE
405 0 : SET_SVANY_FOR_BODYLESS_NV(sv);
406 : #else
407 : SvANY(sv) = new_XNV();
408 : #endif
409 0 : SvNV_set(sv, 0);
410 0 : break;
411 645 : case SVt_PVHV:
412 : case SVt_PVAV:
413 : case SVt_PVOBJ:
414 : assert(type_details->body_size);
415 :
416 : #ifndef PURIFY
417 : assert(type_details->arena);
418 : assert(type_details->arena_size);
419 : /* This points to the start of the allocated area. */
420 645 : new_body = S_new_body(aTHX_ type);
421 : /* xpvav and xpvhv have no offset, so no need to adjust new_body */
422 : assert(!(type_details->offset));
423 : #else
424 : /* We always allocated the full length item with PURIFY. To do this
425 : we fake things so that arena is false for all 16 types.. */
426 : new_body = new_NOARENAZ(type_details);
427 : #endif
428 645 : SvANY(sv) = new_body;
429 :
430 645 : SvSTASH_set(sv, NULL);
431 645 : SvMAGIC_set(sv, NULL);
432 :
433 645 : switch(type) {
434 141 : case SVt_PVAV:
435 141 : AvFILLp(sv) = -1;
436 141 : AvMAX(sv) = -1;
437 141 : AvALLOC(sv) = NULL;
438 :
439 141 : AvREAL_only(sv);
440 141 : break;
441 504 : case SVt_PVHV:
442 504 : HvTOTALKEYS(sv) = 0;
443 : /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
444 504 : HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
445 :
446 : assert(!SvOK(sv));
447 504 : SvOK_off(sv);
448 : #ifndef NODEFAULT_SHAREKEYS
449 504 : HvSHAREKEYS_on(sv); /* key-sharing on by default */
450 : #endif
451 : /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
452 504 : HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
453 504 : break;
454 0 : case SVt_PVOBJ:
455 0 : ObjectMAXFIELD(sv) = -1;
456 0 : ObjectFIELDS(sv) = NULL;
457 0 : break;
458 0 : default:
459 0 : NOT_REACHED;
460 : }
461 :
462 645 : sv->sv_u.svu_array = NULL; /* or svu_hash */
463 645 : break;
464 :
465 0 : case SVt_PVIV:
466 : case SVt_PVIO:
467 : case SVt_PVGV:
468 : case SVt_PVCV:
469 : case SVt_PVLV:
470 : case SVt_INVLIST:
471 : case SVt_REGEXP:
472 : case SVt_PVMG:
473 : case SVt_PVNV:
474 : case SVt_PV:
475 : /* For a type known at compile time, it should be possible for the
476 : * compiler to deduce the value of (type_details->arena), resolve
477 : * that branch below, and inline the relevant values from
478 : * bodies_by_type. Except, at least for gcc, it seems not to do that.
479 : * We help it out here with two deviations from sv_upgrade:
480 : * (1) Minor rearrangement here, so that PVFM - the only type at this
481 : * point not to be allocated from an array appears last, not PV.
482 : * (2) The ASSUME() statement here for everything that isn't PVFM.
483 : * Obviously this all only holds as long as it's a true reflection of
484 : * the bodies_by_type lookup table. */
485 : #ifndef PURIFY
486 0 : ASSUME(type_details->arena);
487 : #endif
488 : /* FALLTHROUGH */
489 : case SVt_PVFM:
490 :
491 : assert(type_details->body_size);
492 : /* We always allocated the full length item with PURIFY. To do this
493 : we fake things so that arena is false for all 16 types.. */
494 : #ifndef PURIFY
495 0 : if(type_details->arena) {
496 : /* This points to the start of the allocated area. */
497 0 : new_body = S_new_body(aTHX_ type);
498 0 : Zero(new_body, type_details->body_size, char);
499 0 : new_body = ((char *)new_body) - type_details->offset;
500 : } else
501 : #endif
502 : {
503 0 : new_body = new_NOARENAZ(type_details);
504 : }
505 0 : SvANY(sv) = new_body;
506 :
507 0 : if (UNLIKELY(type == SVt_PVIO)) {
508 0 : IO * const io = MUTABLE_IO(sv);
509 0 : GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
510 :
511 0 : SvOBJECT_on(io);
512 : /* Clear the stashcache because a new IO could overrule a package
513 : name */
514 : DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n"));
515 0 : hv_clear(PL_stashcache);
516 :
517 0 : SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
518 0 : IoPAGE_LEN(sv) = 60;
519 : }
520 :
521 0 : sv->sv_u.svu_rv = NULL;
522 0 : break;
523 0 : default:
524 0 : Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
525 : (unsigned long)type);
526 : }
527 :
528 1244 : return sv;
529 : }
530 :
531 : /*
532 : =for apidoc newSV_type_mortal
533 :
534 : Creates a new mortal SV, of the type specified. The reference count for the
535 : new SV is set to 1.
536 :
537 : This is equivalent to
538 : SV* sv = sv_2mortal(newSV_type(<some type>))
539 : and
540 : SV* sv = sv_newmortal();
541 : sv_upgrade(sv, <some_type>)
542 : but should be more efficient than both of them. (Unless sv_2mortal is inlined
543 : at some point in the future.)
544 :
545 : =cut
546 : */
547 :
548 : PERL_STATIC_INLINE SV *
549 : Perl_newSV_type_mortal(pTHX_ const svtype type)
550 : {
551 : SV *sv = newSV_type(type);
552 : SSize_t ix = ++PL_tmps_ix;
553 : if (UNLIKELY(ix >= PL_tmps_max))
554 : ix = Perl_tmps_grow_p(aTHX_ ix);
555 : PL_tmps_stack[ix] = (sv);
556 : SvTEMP_on(sv);
557 : return sv;
558 : }
559 :
560 : /* The following functions started out in sv.h and then moved to inline.h. They
561 : * moved again into this file during the 5.37.x development cycle. */
562 :
563 : /*
564 : =for apidoc_section $SV
565 : =for apidoc SvPVXtrue
566 :
567 : Returns a boolean as to whether or not C<sv> contains a PV that is considered
568 : TRUE. FALSE is returned if C<sv> doesn't contain a PV, or if the PV it does
569 : contain is zero length, or consists of just the single character '0'. Every
570 : other PV value is considered TRUE.
571 :
572 : As of Perl v5.37.1, C<sv> is evaluated exactly once; in earlier releases, it
573 : could be evaluated more than once.
574 :
575 : =cut
576 : */
577 :
578 : PERL_STATIC_INLINE bool
579 : Perl_SvPVXtrue(pTHX_ SV *sv)
580 : {
581 : PERL_ARGS_ASSERT_SVPVXTRUE;
582 :
583 : PERL_UNUSED_CONTEXT;
584 :
585 533 : if (! (XPV *) SvANY(sv)) {
586 0 : return false;
587 : }
588 :
589 533 : if ( ((XPV *) SvANY(sv))->xpv_cur > 1) { /* length > 1 */
590 29 : return true;
591 : }
592 :
593 504 : if (( (XPV *) SvANY(sv))->xpv_cur == 0) {
594 500 : return false;
595 : }
596 :
597 4 : return *sv->sv_u.svu_pv != '0';
598 : }
599 :
600 : /*
601 : =for apidoc SvGETMAGIC
602 : Invokes C<L</mg_get>> on an SV if it has 'get' magic. For example, this
603 : will call C<FETCH> on a tied variable. As of 5.37.1, this function is
604 : guaranteed to evaluate its argument exactly once.
605 :
606 : =cut
607 : */
608 :
609 : PERL_STATIC_INLINE void
610 533 : Perl_SvGETMAGIC(pTHX_ SV *sv)
611 : {
612 : PERL_ARGS_ASSERT_SVGETMAGIC;
613 :
614 533 : if (UNLIKELY(SvGMAGICAL(sv))) {
615 0 : mg_get(sv);
616 : }
617 533 : }
618 :
619 : PERL_STATIC_INLINE bool
620 533 : Perl_SvTRUE(pTHX_ SV *sv)
621 : {
622 : PERL_ARGS_ASSERT_SVTRUE;
623 :
624 533 : if (UNLIKELY(sv == NULL))
625 0 : return FALSE;
626 533 : SvGETMAGIC(sv);
627 533 : return SvTRUE_nomg_NN(sv);
628 : }
629 :
630 : PERL_STATIC_INLINE bool
631 : Perl_SvTRUE_nomg(pTHX_ SV *sv)
632 : {
633 : PERL_ARGS_ASSERT_SVTRUE_NOMG;
634 :
635 : if (UNLIKELY(sv == NULL))
636 : return FALSE;
637 : return SvTRUE_nomg_NN(sv);
638 : }
639 :
640 : PERL_STATIC_INLINE bool
641 : Perl_SvTRUE_NN(pTHX_ SV *sv)
642 : {
643 : PERL_ARGS_ASSERT_SVTRUE_NN;
644 :
645 : SvGETMAGIC(sv);
646 : return SvTRUE_nomg_NN(sv);
647 : }
648 :
649 : PERL_STATIC_INLINE bool
650 533 : Perl_SvTRUE_common(pTHX_ SV * sv, const bool sv_2bool_is_fallback)
651 : {
652 : PERL_ARGS_ASSERT_SVTRUE_COMMON;
653 :
654 533 : if (UNLIKELY(SvIMMORTAL_INTERP(sv)))
655 0 : return SvIMMORTAL_TRUE(sv);
656 :
657 533 : if (! SvOK(sv))
658 0 : return FALSE;
659 :
660 533 : if (SvPOK(sv))
661 533 : return SvPVXtrue(sv);
662 :
663 0 : if (SvIOK(sv))
664 0 : return SvIVX(sv) != 0; /* casts to bool */
665 :
666 0 : if (SvROK(sv) && !(SvOBJECT(SvRV(sv)) && HvAMAGIC(SvSTASH(SvRV(sv)))))
667 0 : return TRUE;
668 :
669 0 : if (sv_2bool_is_fallback)
670 0 : return sv_2bool_nomg(sv);
671 :
672 0 : return isGV_with_GP(sv);
673 : }
674 :
675 : PERL_STATIC_INLINE SV *
676 0 : Perl_SvREFCNT_inc(SV *sv)
677 : {
678 0 : if (LIKELY(sv != NULL))
679 0 : SvREFCNT(sv)++;
680 0 : return sv;
681 : }
682 :
683 : PERL_STATIC_INLINE SV *
684 : Perl_SvREFCNT_inc_NN(SV *sv)
685 : {
686 : PERL_ARGS_ASSERT_SVREFCNT_INC_NN;
687 :
688 : SvREFCNT(sv)++;
689 : return sv;
690 : }
691 :
692 : PERL_STATIC_INLINE void
693 : Perl_SvREFCNT_inc_void(SV *sv)
694 : {
695 : if (LIKELY(sv != NULL))
696 : SvREFCNT(sv)++;
697 : }
698 :
699 : PERL_STATIC_INLINE void
700 1426 : Perl_SvREFCNT_dec(pTHX_ SV *sv)
701 : {
702 1426 : if (LIKELY(sv != NULL)) {
703 1426 : U32 rc = SvREFCNT(sv);
704 1426 : if (LIKELY(rc > 1))
705 1016 : SvREFCNT(sv) = rc - 1;
706 : else
707 410 : Perl_sv_free2(aTHX_ sv, rc);
708 : }
709 1426 : }
710 :
711 : PERL_STATIC_INLINE SV *
712 : Perl_SvREFCNT_dec_ret_NULL(pTHX_ SV *sv)
713 : {
714 : PERL_ARGS_ASSERT_SVREFCNT_DEC_RET_NULL;
715 : Perl_SvREFCNT_dec(aTHX_ sv);
716 : return NULL;
717 : }
718 :
719 :
720 : PERL_STATIC_INLINE void
721 : Perl_SvREFCNT_dec_NN(pTHX_ SV *sv)
722 : {
723 : U32 rc = SvREFCNT(sv);
724 :
725 : PERL_ARGS_ASSERT_SVREFCNT_DEC_NN;
726 :
727 : if (LIKELY(rc > 1))
728 : SvREFCNT(sv) = rc - 1;
729 : else
730 : Perl_sv_free2(aTHX_ sv, rc);
731 : }
732 :
733 : /*
734 : =for apidoc SvAMAGIC_on
735 :
736 : Indicate that C<sv> has overloading (active magic) enabled.
737 :
738 : =cut
739 : */
740 :
741 : PERL_STATIC_INLINE void
742 : Perl_SvAMAGIC_on(SV *sv)
743 : {
744 : PERL_ARGS_ASSERT_SVAMAGIC_ON;
745 : assert(SvROK(sv));
746 :
747 : if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
748 : }
749 :
750 : /*
751 : =for apidoc SvAMAGIC_off
752 :
753 : Indicate that C<sv> has overloading (active magic) disabled.
754 :
755 : =cut
756 : */
757 :
758 : PERL_STATIC_INLINE void
759 : Perl_SvAMAGIC_off(SV *sv)
760 : {
761 : PERL_ARGS_ASSERT_SVAMAGIC_OFF;
762 :
763 : if (SvROK(sv) && SvOBJECT(SvRV(sv)))
764 : HvAMAGIC_off(SvSTASH(SvRV(sv)));
765 : }
766 :
767 : PERL_STATIC_INLINE U32
768 : Perl_SvPADSTALE_on(SV *sv)
769 : {
770 : assert(!(SvFLAGS(sv) & SVs_PADTMP));
771 : return SvFLAGS(sv) |= SVs_PADSTALE;
772 : }
773 : PERL_STATIC_INLINE U32
774 : Perl_SvPADSTALE_off(SV *sv)
775 : {
776 : assert(!(SvFLAGS(sv) & SVs_PADTMP));
777 : return SvFLAGS(sv) &= ~SVs_PADSTALE;
778 : }
779 :
780 : /*
781 : =for apidoc_section $SV
782 : =for apidoc SvIV
783 : =for apidoc_item SvIV_nomg
784 : =for apidoc_item SvIVx
785 :
786 : These each coerce the given SV to IV and return it. The returned value in many
787 : circumstances will get stored in C<sv>'s IV slot, but not in all cases. (Use
788 : C<L</sv_setiv>> to make sure it does).
789 :
790 : As of 5.37.1, all are guaranteed to evaluate C<sv> only once.
791 :
792 : C<SvIVx> is now identical to C<SvIV>, but prior to 5.37.1, it was the only form
793 : guaranteed to evaluate C<sv> only once.
794 :
795 : C<SvIV_nomg> is the same as C<SvIV>, but does not perform 'get' magic.
796 :
797 : =for apidoc SvNV
798 : =for apidoc_item SvNV_nomg
799 : =for apidoc_item SvNVx
800 :
801 : These each coerce the given SV to NV and return it. The returned value in many
802 : circumstances will get stored in C<sv>'s NV slot, but not in all cases. (Use
803 : C<L</sv_setnv>> to make sure it does).
804 :
805 : As of 5.37.1, all are guaranteed to evaluate C<sv> only once.
806 :
807 : C<SvNVx> is now identical to C<SvNV>, but prior to 5.37.1, it was the only form
808 : guaranteed to evaluate C<sv> only once.
809 :
810 : C<SvNV_nomg> is the same as C<SvNV>, but does not perform 'get' magic.
811 :
812 : =for apidoc SvUV
813 : =for apidoc_item SvUV_nomg
814 : =for apidoc_item SvUVx
815 :
816 : These each coerce the given SV to UV and return it. The returned value in many
817 : circumstances will get stored in C<sv>'s UV slot, but not in all cases. (Use
818 : C<L</sv_setuv>> to make sure it does).
819 :
820 : As of 5.37.1, all are guaranteed to evaluate C<sv> only once.
821 :
822 : C<SvUVx> is now identical to C<SvUV>, but prior to 5.37.1, it was the only form
823 : guaranteed to evaluate C<sv> only once.
824 :
825 : =cut
826 : */
827 :
828 : PERL_STATIC_INLINE IV
829 196 : Perl_SvIV(pTHX_ SV *sv) {
830 : PERL_ARGS_ASSERT_SVIV;
831 :
832 196 : if (SvIOK_nog(sv))
833 196 : return SvIVX(sv);
834 0 : return sv_2iv(sv);
835 : }
836 :
837 : PERL_STATIC_INLINE UV
838 : Perl_SvUV(pTHX_ SV *sv) {
839 : PERL_ARGS_ASSERT_SVUV;
840 :
841 : if (SvUOK_nog(sv))
842 : return SvUVX(sv);
843 : return sv_2uv(sv);
844 : }
845 :
846 : PERL_STATIC_INLINE NV
847 106 : Perl_SvNV(pTHX_ SV *sv) {
848 : PERL_ARGS_ASSERT_SVNV;
849 :
850 106 : if (SvNOK_nog(sv))
851 57 : return SvNVX(sv);
852 49 : return sv_2nv(sv);
853 : }
854 :
855 : PERL_STATIC_INLINE IV
856 : Perl_SvIV_nomg(pTHX_ SV *sv) {
857 : PERL_ARGS_ASSERT_SVIV_NOMG;
858 :
859 : if (SvIOK(sv))
860 : return SvIVX(sv);
861 : return sv_2iv_flags(sv, 0);
862 : }
863 :
864 : PERL_STATIC_INLINE UV
865 : Perl_SvUV_nomg(pTHX_ SV *sv) {
866 : PERL_ARGS_ASSERT_SVUV_NOMG;
867 :
868 : if (SvUOK(sv))
869 : return SvUVX(sv);
870 : return sv_2uv_flags(sv, 0);
871 : }
872 :
873 : PERL_STATIC_INLINE NV
874 : Perl_SvNV_nomg(pTHX_ SV *sv) {
875 : PERL_ARGS_ASSERT_SVNV_NOMG;
876 :
877 : if (SvNOK(sv))
878 : return SvNVX(sv);
879 : return sv_2nv_flags(sv, 0);
880 : }
881 :
882 : #if defined(PERL_CORE) || defined (PERL_EXT)
883 : PERL_STATIC_INLINE STRLEN
884 : S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
885 : {
886 : PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
887 : if (SvGAMAGIC(sv)) {
888 : U8 *hopped = utf8_hop((U8 *)pv, pos);
889 : if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);
890 : return (STRLEN)(hopped - (U8 *)pv);
891 : }
892 : return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN);
893 : }
894 : #endif
895 :
896 : PERL_STATIC_INLINE char *
897 : Perl_sv_pvutf8n_force_wrapper(pTHX_ SV * const sv, STRLEN * const lp, const U32 dummy)
898 : {
899 : /* This is just so can be passed to Perl_SvPV_helper() as a function
900 : * pointer with the same signature as all the other such pointers, and
901 : * having hence an unused parameter */
902 : PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE_WRAPPER;
903 : PERL_UNUSED_ARG(dummy);
904 :
905 : return sv_pvutf8n_force(sv, lp);
906 : }
907 :
908 : PERL_STATIC_INLINE char *
909 : Perl_sv_pvbyten_force_wrapper(pTHX_ SV * const sv, STRLEN * const lp, const U32 dummy)
910 : {
911 : /* This is just so can be passed to Perl_SvPV_helper() as a function
912 : * pointer with the same signature as all the other such pointers, and
913 : * having hence an unused parameter */
914 : PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE_WRAPPER;
915 : PERL_UNUSED_ARG(dummy);
916 :
917 : return sv_pvbyten_force(sv, lp);
918 : }
919 :
920 : PERL_STATIC_INLINE char *
921 1127 : Perl_SvPV_helper(pTHX_
922 : SV * const sv,
923 : STRLEN * const lp,
924 : const U32 flags,
925 : const PL_SvPVtype type,
926 : char * (*non_trivial)(pTHX_ SV *, STRLEN * const, const U32),
927 : const bool or_null,
928 : const U32 return_flags
929 : )
930 : {
931 : /* 'type' should be known at compile time, so this is reduced to a single
932 : * conditional at runtime */
933 1127 : if ( (type == SvPVbyte_type_ && SvPOK_byte_nog(sv))
934 1120 : || (type == SvPVforce_type_ && SvPOK_pure_nogthink(sv))
935 1120 : || (type == SvPVutf8_type_ && SvPOK_utf8_nog(sv))
936 673 : || (type == SvPVnormal_type_ && SvPOK_nog(sv))
937 659 : || (type == SvPVutf8_pure_type_ && SvPOK_utf8_pure_nogthink(sv))
938 659 : || (type == SvPVbyte_pure_type_ && SvPOK_byte_pure_nogthink(sv))
939 : ) {
940 468 : if (lp) {
941 459 : *lp = SvCUR(sv);
942 : }
943 :
944 : /* Similarly 'return_flags is known at compile time, so this becomes
945 : * branchless */
946 468 : if (return_flags & SV_MUTABLE_RETURN) {
947 0 : return SvPVX_mutable(sv);
948 : }
949 468 : else if(return_flags & SV_CONST_RETURN) {
950 0 : return (char *) SvPVX_const(sv);
951 : }
952 : else {
953 468 : return SvPVX(sv);
954 : }
955 : }
956 :
957 659 : if (or_null) { /* This is also known at compile time */
958 0 : if (flags & SV_GMAGIC) { /* As is this */
959 0 : SvGETMAGIC(sv);
960 : }
961 :
962 0 : if (! SvOK(sv)) {
963 0 : if (lp) { /* As is this */
964 0 : *lp = 0;
965 : }
966 :
967 0 : return NULL;
968 : }
969 : }
970 :
971 : /* Can't trivially handle this, call the function */
972 659 : return non_trivial(aTHX_ sv, lp, (flags|return_flags));
973 : }
974 :
975 : /*
976 : =for apidoc newRV_noinc
977 :
978 : Creates an RV wrapper for an SV. The reference count for the original
979 : SV is B<not> incremented.
980 :
981 : =cut
982 : */
983 :
984 : PERL_STATIC_INLINE SV *
985 599 : Perl_newRV_noinc(pTHX_ SV *const tmpRef)
986 : {
987 599 : SV *sv = newSV_type(SVt_IV);
988 :
989 : PERL_ARGS_ASSERT_NEWRV_NOINC;
990 :
991 599 : SvTEMP_off(tmpRef);
992 :
993 : /* inlined, simplified sv_setrv_noinc(sv, tmpRef); */
994 599 : SvRV_set(sv, tmpRef);
995 599 : SvROK_on(sv);
996 :
997 599 : return sv;
998 : }
999 :
1000 : PERL_STATIC_INLINE char *
1001 : Perl_sv_setpv_freshbuf(pTHX_ SV *const sv)
1002 : {
1003 : PERL_ARGS_ASSERT_SV_SETPV_FRESHBUF;
1004 : assert(SvTYPE(sv) >= SVt_PV);
1005 : assert(SvTYPE(sv) <= SVt_PVMG);
1006 : assert(!SvTHINKFIRST(sv));
1007 : assert(SvPVX(sv));
1008 : SvCUR_set(sv, 0);
1009 : *(SvEND(sv))= '\0';
1010 : (void)SvPOK_only_UTF8(sv); /* UTF-8 flag will be 0; This is used instead
1011 : of 'SvPOK_only' because the other sv_setpv
1012 : functions use it */
1013 : SvTAINT(sv);
1014 : return SvPVX(sv);
1015 : }
1016 :
1017 : /*
1018 : * ex: set ts=8 sts=4 sw=4 et:
1019 : */
|
