Commit | Line | Data |
---|---|---|
7ea8b04b | 1 | /* sv_inline.h |
75acd14e | 2 | * |
7ea8b04b | 3 | * Copyright (C) 2022 by Larry Wall and others |
75acd14e RL |
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 | ||
7ea8b04b RL |
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 | */ | |
75acd14e | 22 | |
7ea8b04b | 23 | /* This definition came from perl.h*/ |
75acd14e RL |
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. | |
7ea8b04b | 67 | * but the function declaration seems to be needed. */ |
75acd14e RL |
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 : 4; /* 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 | ||
153 | #define HADNV FALSE | |
154 | #define NONV TRUE | |
155 | ||
156 | ||
157 | #ifdef PURIFY | |
158 | /* With -DPURFIY we allocate everything directly, and don't use arenas. | |
159 | This seems a rather elegant way to simplify some of the code below. */ | |
160 | #define HASARENA FALSE | |
161 | #else | |
162 | #define HASARENA TRUE | |
163 | #endif | |
164 | #define NOARENA FALSE | |
165 | ||
166 | /* Size the arenas to exactly fit a given number of bodies. A count | |
167 | of 0 fits the max number bodies into a PERL_ARENA_SIZE.block, | |
168 | simplifying the default. If count > 0, the arena is sized to fit | |
169 | only that many bodies, allowing arenas to be used for large, rare | |
170 | bodies (XPVFM, XPVIO) without undue waste. The arena size is | |
171 | limited by PERL_ARENA_SIZE, so we can safely oversize the | |
172 | declarations. | |
173 | */ | |
174 | #define FIT_ARENA0(body_size) \ | |
175 | ((size_t)(PERL_ARENA_SIZE / body_size) * body_size) | |
176 | #define FIT_ARENAn(count,body_size) \ | |
177 | ( count * body_size <= PERL_ARENA_SIZE) \ | |
178 | ? count * body_size \ | |
179 | : FIT_ARENA0 (body_size) | |
180 | #define FIT_ARENA(count,body_size) \ | |
181 | (U32)(count \ | |
182 | ? FIT_ARENAn (count, body_size) \ | |
183 | : FIT_ARENA0 (body_size)) | |
184 | ||
185 | /* Calculate the length to copy. Specifically work out the length less any | |
186 | final padding the compiler needed to add. See the comment in sv_upgrade | |
187 | for why copying the padding proved to be a bug. */ | |
188 | ||
189 | #define copy_length(type, last_member) \ | |
190 | STRUCT_OFFSET(type, last_member) \ | |
191 | + sizeof (((type*)SvANY((const SV *)0))->last_member) | |
192 | ||
193 | static const struct body_details bodies_by_type[] = { | |
194 | /* HEs use this offset for their arena. */ | |
195 | { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 }, | |
196 | ||
197 | /* IVs are in the head, so the allocation size is 0. */ | |
198 | { 0, | |
199 | sizeof(IV), /* This is used to copy out the IV body. */ | |
200 | STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV, | |
201 | NOARENA /* IVS don't need an arena */, 0 | |
202 | }, | |
203 | ||
204 | #if NVSIZE <= IVSIZE | |
205 | { 0, sizeof(NV), | |
206 | STRUCT_OFFSET(XPVNV, xnv_u), | |
207 | SVt_NV, FALSE, HADNV, NOARENA, 0 }, | |
208 | #else | |
209 | { sizeof(NV), sizeof(NV), | |
210 | STRUCT_OFFSET(XPVNV, xnv_u), | |
211 | SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) }, | |
212 | #endif | |
213 | ||
214 | { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur), | |
215 | copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur), | |
216 | + STRUCT_OFFSET(XPV, xpv_cur), | |
217 | SVt_PV, FALSE, NONV, HASARENA, | |
218 | FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) }, | |
219 | ||
220 | { sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur), | |
221 | copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur), | |
222 | + STRUCT_OFFSET(XPV, xpv_cur), | |
223 | SVt_INVLIST, TRUE, NONV, HASARENA, | |
224 | FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)) }, | |
225 | ||
226 | { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur), | |
227 | copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur), | |
228 | + STRUCT_OFFSET(XPV, xpv_cur), | |
229 | SVt_PVIV, FALSE, NONV, HASARENA, | |
230 | FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) }, | |
231 | ||
232 | { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur), | |
233 | copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur), | |
234 | + STRUCT_OFFSET(XPV, xpv_cur), | |
235 | SVt_PVNV, FALSE, HADNV, HASARENA, | |
236 | FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) }, | |
237 | ||
238 | { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV, | |
239 | HASARENA, FIT_ARENA(0, sizeof(XPVMG)) }, | |
240 | ||
241 | { sizeof(ALIGNED_TYPE_NAME(regexp)), | |
242 | sizeof(regexp), | |
243 | 0, | |
244 | SVt_REGEXP, TRUE, NONV, HASARENA, | |
245 | FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(regexp))) | |
246 | }, | |
247 | ||
248 | { sizeof(ALIGNED_TYPE_NAME(XPVGV)), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV, | |
249 | HASARENA, FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVGV))) }, | |
250 | ||
251 | { sizeof(ALIGNED_TYPE_NAME(XPVLV)), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV, | |
252 | HASARENA, FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVLV))) }, | |
253 | ||
254 | { sizeof(ALIGNED_TYPE_NAME(XPVAV)), | |
255 | copy_length(XPVAV, xav_alloc), | |
256 | 0, | |
257 | SVt_PVAV, TRUE, NONV, HASARENA, | |
258 | FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVAV))) }, | |
259 | ||
260 | { sizeof(ALIGNED_TYPE_NAME(XPVHV)), | |
261 | copy_length(XPVHV, xhv_max), | |
262 | 0, | |
263 | SVt_PVHV, TRUE, NONV, HASARENA, | |
264 | FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVHV))) }, | |
265 | ||
266 | { sizeof(ALIGNED_TYPE_NAME(XPVCV)), | |
267 | sizeof(XPVCV), | |
268 | 0, | |
269 | SVt_PVCV, TRUE, NONV, HASARENA, | |
270 | FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVCV))) }, | |
271 | ||
272 | { sizeof(ALIGNED_TYPE_NAME(XPVFM)), | |
273 | sizeof(XPVFM), | |
274 | 0, | |
275 | SVt_PVFM, TRUE, NONV, NOARENA, | |
276 | FIT_ARENA(20, sizeof(ALIGNED_TYPE_NAME(XPVFM))) }, | |
277 | ||
278 | { sizeof(ALIGNED_TYPE_NAME(XPVIO)), | |
279 | sizeof(XPVIO), | |
280 | 0, | |
281 | SVt_PVIO, TRUE, NONV, HASARENA, | |
282 | FIT_ARENA(24, sizeof(ALIGNED_TYPE_NAME(XPVIO))) }, | |
283 | }; | |
284 | ||
285 | #define new_body_allocated(sv_type) \ | |
286 | (void *)((char *)S_new_body(aTHX_ sv_type) \ | |
287 | - bodies_by_type[sv_type].offset) | |
288 | ||
289 | #ifdef PURIFY | |
290 | #if !(NVSIZE <= IVSIZE) | |
291 | # define new_XNV() safemalloc(sizeof(XPVNV)) | |
292 | #endif | |
293 | #define new_XPVNV() safemalloc(sizeof(XPVNV)) | |
294 | #define new_XPVMG() safemalloc(sizeof(XPVMG)) | |
295 | ||
296 | #define del_body_by_type(p, type) safefree(p) | |
297 | ||
298 | #else /* !PURIFY */ | |
299 | ||
300 | #if !(NVSIZE <= IVSIZE) | |
301 | # define new_XNV() new_body_allocated(SVt_NV) | |
302 | #endif | |
303 | #define new_XPVNV() new_body_allocated(SVt_PVNV) | |
304 | #define new_XPVMG() new_body_allocated(SVt_PVMG) | |
305 | ||
306 | #define del_body_by_type(p, type) \ | |
307 | del_body(p + bodies_by_type[(type)].offset, \ | |
308 | &PL_body_roots[(type)]) | |
309 | ||
310 | #endif /* PURIFY */ | |
311 | ||
312 | /* no arena for you! */ | |
313 | ||
314 | #define new_NOARENA(details) \ | |
315 | safemalloc((details)->body_size + (details)->offset) | |
316 | #define new_NOARENAZ(details) \ | |
317 | safecalloc((details)->body_size + (details)->offset, 1) | |
318 | ||
319 | #ifndef PURIFY | |
320 | ||
321 | /* grab a new thing from the arena's free list, allocating more if necessary. */ | |
322 | #define new_body_from_arena(xpv, root_index, type_meta) \ | |
323 | STMT_START { \ | |
324 | void ** const r3wt = &PL_body_roots[root_index]; \ | |
325 | xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \ | |
326 | ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ root_index, \ | |
327 | type_meta.body_size,\ | |
328 | type_meta.arena_size)); \ | |
329 | *(r3wt) = *(void**)(xpv); \ | |
330 | } STMT_END | |
331 | ||
332 | PERL_STATIC_INLINE void * | |
333 | S_new_body(pTHX_ const svtype sv_type) | |
334 | { | |
335 | void *xpv; | |
336 | new_body_from_arena(xpv, sv_type, bodies_by_type[sv_type]); | |
337 | return xpv; | |
338 | } | |
339 | ||
340 | #endif | |
341 | ||
342 | static const struct body_details fake_rv = | |
343 | { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 }; | |
344 | ||
345 | static const struct body_details fake_hv_with_aux = | |
346 | /* The SVt_IV arena is used for (larger) PVHV bodies. */ | |
347 | { sizeof(ALIGNED_TYPE_NAME(XPVHV_WITH_AUX)), | |
348 | copy_length(XPVHV, xhv_max), | |
349 | 0, | |
350 | SVt_PVHV, TRUE, NONV, HASARENA, | |
351 | FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVHV_WITH_AUX))) }; | |
352 | ||
353 | /* | |
354 | =for apidoc newSV_type | |
355 | ||
356 | Creates a new SV, of the type specified. The reference count for the new SV | |
357 | is set to 1. | |
358 | ||
359 | =cut | |
360 | */ | |
361 | ||
362 | PERL_STATIC_INLINE SV * | |
363 | Perl_newSV_type(pTHX_ const svtype type) | |
364 | { | |
365 | SV *sv; | |
366 | void* new_body; | |
367 | const struct body_details *type_details; | |
368 | ||
369 | new_SV(sv); | |
370 | ||
371 | type_details = bodies_by_type + type; | |
372 | ||
373 | SvFLAGS(sv) &= ~SVTYPEMASK; | |
374 | SvFLAGS(sv) |= type; | |
375 | ||
376 | switch (type) { | |
377 | case SVt_NULL: | |
378 | break; | |
379 | case SVt_IV: | |
380 | SET_SVANY_FOR_BODYLESS_IV(sv); | |
381 | SvIV_set(sv, 0); | |
382 | break; | |
383 | case SVt_NV: | |
384 | #if NVSIZE <= IVSIZE | |
385 | SET_SVANY_FOR_BODYLESS_NV(sv); | |
386 | #else | |
387 | SvANY(sv) = new_XNV(); | |
388 | #endif | |
389 | SvNV_set(sv, 0); | |
390 | break; | |
391 | case SVt_PVHV: | |
392 | case SVt_PVAV: | |
393 | assert(type_details->body_size); | |
394 | ||
395 | #ifndef PURIFY | |
396 | assert(type_details->arena); | |
397 | assert(type_details->arena_size); | |
398 | /* This points to the start of the allocated area. */ | |
399 | new_body = S_new_body(aTHX_ type); | |
400 | /* xpvav and xpvhv have no offset, so no need to adjust new_body */ | |
401 | assert(!(type_details->offset)); | |
402 | #else | |
403 | /* We always allocated the full length item with PURIFY. To do this | |
404 | we fake things so that arena is false for all 16 types.. */ | |
405 | new_body = new_NOARENAZ(type_details); | |
406 | #endif | |
407 | SvANY(sv) = new_body; | |
408 | ||
409 | SvSTASH_set(sv, NULL); | |
410 | SvMAGIC_set(sv, NULL); | |
411 | ||
412 | if (type == SVt_PVAV) { | |
413 | AvFILLp(sv) = -1; | |
414 | AvMAX(sv) = -1; | |
415 | AvALLOC(sv) = NULL; | |
416 | ||
417 | AvREAL_only(sv); | |
418 | } else { | |
419 | HvTOTALKEYS(sv) = 0; | |
420 | /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */ | |
421 | HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX; | |
422 | ||
423 | assert(!SvOK(sv)); | |
424 | SvOK_off(sv); | |
425 | #ifndef NODEFAULT_SHAREKEYS | |
426 | HvSHAREKEYS_on(sv); /* key-sharing on by default */ | |
427 | #endif | |
428 | /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */ | |
429 | HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX; | |
430 | } | |
431 | ||
432 | sv->sv_u.svu_array = NULL; /* or svu_hash */ | |
433 | break; | |
434 | ||
435 | case SVt_PVIV: | |
436 | case SVt_PVIO: | |
437 | case SVt_PVGV: | |
438 | case SVt_PVCV: | |
439 | case SVt_PVLV: | |
440 | case SVt_INVLIST: | |
441 | case SVt_REGEXP: | |
442 | case SVt_PVMG: | |
443 | case SVt_PVNV: | |
444 | case SVt_PV: | |
445 | /* For a type known at compile time, it should be possible for the | |
446 | * compiler to deduce the value of (type_details->arena), resolve | |
447 | * that branch below, and inline the relevant values from | |
448 | * bodies_by_type. Except, at least for gcc, it seems not to do that. | |
449 | * We help it out here with two deviations from sv_upgrade: | |
450 | * (1) Minor rearrangement here, so that PVFM - the only type at this | |
451 | * point not to be allocated from an array appears last, not PV. | |
452 | * (2) The ASSUME() statement here for everything that isn't PVFM. | |
453 | * Obviously this all only holds as long as it's a true reflection of | |
454 | * the bodies_by_type lookup table. */ | |
455 | #ifndef PURIFY | |
456 | ASSUME(type_details->arena); | |
457 | #endif | |
458 | /* FALLTHROUGH */ | |
459 | case SVt_PVFM: | |
460 | ||
461 | assert(type_details->body_size); | |
462 | /* We always allocated the full length item with PURIFY. To do this | |
463 | we fake things so that arena is false for all 16 types.. */ | |
464 | #ifndef PURIFY | |
465 | if(type_details->arena) { | |
466 | /* This points to the start of the allocated area. */ | |
467 | new_body = S_new_body(aTHX_ type); | |
468 | Zero(new_body, type_details->body_size, char); | |
469 | new_body = ((char *)new_body) - type_details->offset; | |
470 | } else | |
471 | #endif | |
472 | { | |
473 | new_body = new_NOARENAZ(type_details); | |
474 | } | |
475 | SvANY(sv) = new_body; | |
476 | ||
477 | if (UNLIKELY(type == SVt_PVIO)) { | |
478 | IO * const io = MUTABLE_IO(sv); | |
479 | GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV); | |
480 | ||
481 | SvOBJECT_on(io); | |
482 | /* Clear the stashcache because a new IO could overrule a package | |
483 | name */ | |
484 | DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n")); | |
485 | hv_clear(PL_stashcache); | |
486 | ||
487 | SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv)))); | |
488 | IoPAGE_LEN(sv) = 60; | |
489 | } | |
490 | ||
491 | sv->sv_u.svu_rv = NULL; | |
492 | break; | |
493 | default: | |
494 | Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", | |
495 | (unsigned long)type); | |
496 | } | |
497 | ||
498 | return sv; | |
499 | } | |
500 | ||
501 | /* | |
7ea8b04b RL |
502 | =for apidoc newSV_type_mortal |
503 | ||
504 | Creates a new mortal SV, of the type specified. The reference count for the | |
505 | new SV is set to 1. | |
506 | ||
507 | This is equivalent to | |
508 | SV* sv = sv_2mortal(newSV_type(<some type>)) | |
509 | and | |
510 | SV* sv = sv_newmortal(); | |
511 | sv_upgrade(sv, <some_type>) | |
512 | but should be more efficient than both of them. (Unless sv_2mortal is inlined | |
513 | at some point in the future.) | |
514 | ||
515 | =cut | |
516 | */ | |
517 | ||
518 | PERL_STATIC_INLINE SV * | |
519 | Perl_newSV_type_mortal(pTHX_ const svtype type) | |
520 | { | |
521 | SV *sv = newSV_type(type); | |
522 | SSize_t ix = ++PL_tmps_ix; | |
523 | if (UNLIKELY(ix >= PL_tmps_max)) | |
524 | ix = Perl_tmps_grow_p(aTHX_ ix); | |
525 | PL_tmps_stack[ix] = (sv); | |
526 | SvTEMP_on(sv); | |
527 | return sv; | |
528 | } | |
529 | ||
2356f8bb RL |
530 | /* The following functions started out in sv.h and then moved to inline.h. They |
531 | * moved again into this file during the 5.37.x development cycle. */ | |
532 | ||
533 | /* | |
534 | =for apidoc_section $SV | |
535 | =for apidoc SvPVXtrue | |
536 | ||
537 | Returns a boolean as to whether or not C<sv> contains a PV that is considered | |
538 | TRUE. FALSE is returned if C<sv> doesn't contain a PV, or if the PV it does | |
539 | contain is zero length, or consists of just the single character '0'. Every | |
540 | other PV value is considered TRUE. | |
541 | ||
542 | As of Perl v5.37.1, C<sv> is evaluated exactly once; in earlier releases, it | |
543 | could be evaluated more than once. | |
544 | ||
545 | =cut | |
546 | */ | |
547 | ||
548 | PERL_STATIC_INLINE bool | |
549 | Perl_SvPVXtrue(pTHX_ SV *sv) | |
550 | { | |
551 | PERL_ARGS_ASSERT_SVPVXTRUE; | |
552 | ||
553 | if (! (XPV *) SvANY(sv)) { | |
554 | return false; | |
555 | } | |
556 | ||
557 | if ( ((XPV *) SvANY(sv))->xpv_cur > 1) { /* length > 1 */ | |
558 | return true; | |
559 | } | |
560 | ||
561 | if (( (XPV *) SvANY(sv))->xpv_cur == 0) { | |
562 | return false; | |
563 | } | |
564 | ||
565 | return *sv->sv_u.svu_pv != '0'; | |
566 | } | |
567 | ||
7ea9c672 KW |
568 | /* |
569 | =for apidoc SvGETMAGIC | |
570 | Invokes C<L</mg_get>> on an SV if it has 'get' magic. For example, this | |
571 | will call C<FETCH> on a tied variable. As of 5.37.1, this function is | |
572 | guaranteed to evaluate its argument exactly once. | |
573 | ||
574 | =cut | |
575 | */ | |
576 | ||
577 | PERL_STATIC_INLINE void | |
578 | Perl_SvGETMAGIC(pTHX_ SV *sv) | |
579 | { | |
580 | PERL_ARGS_ASSERT_SVGETMAGIC; | |
581 | ||
582 | if (UNLIKELY(SvGMAGICAL(sv))) { | |
583 | mg_get(sv); | |
584 | } | |
585 | } | |
586 | ||
2356f8bb RL |
587 | PERL_STATIC_INLINE bool |
588 | Perl_SvTRUE(pTHX_ SV *sv) | |
589 | { | |
590 | PERL_ARGS_ASSERT_SVTRUE; | |
591 | ||
592 | if (UNLIKELY(sv == NULL)) | |
593 | return FALSE; | |
594 | SvGETMAGIC(sv); | |
595 | return SvTRUE_nomg_NN(sv); | |
596 | } | |
597 | ||
598 | PERL_STATIC_INLINE bool | |
599 | Perl_SvTRUE_nomg(pTHX_ SV *sv) | |
600 | { | |
601 | PERL_ARGS_ASSERT_SVTRUE_NOMG; | |
602 | ||
603 | if (UNLIKELY(sv == NULL)) | |
604 | return FALSE; | |
605 | return SvTRUE_nomg_NN(sv); | |
606 | } | |
607 | ||
608 | PERL_STATIC_INLINE bool | |
609 | Perl_SvTRUE_NN(pTHX_ SV *sv) | |
610 | { | |
611 | PERL_ARGS_ASSERT_SVTRUE_NN; | |
612 | ||
613 | SvGETMAGIC(sv); | |
614 | return SvTRUE_nomg_NN(sv); | |
615 | } | |
616 | ||
617 | PERL_STATIC_INLINE bool | |
618 | Perl_SvTRUE_common(pTHX_ SV * sv, const bool sv_2bool_is_fallback) | |
619 | { | |
620 | PERL_ARGS_ASSERT_SVTRUE_COMMON; | |
621 | ||
622 | if (UNLIKELY(SvIMMORTAL_INTERP(sv))) | |
623 | return SvIMMORTAL_TRUE(sv); | |
624 | ||
625 | if (! SvOK(sv)) | |
626 | return FALSE; | |
627 | ||
628 | if (SvPOK(sv)) | |
629 | return SvPVXtrue(sv); | |
630 | ||
631 | if (SvIOK(sv)) | |
632 | return SvIVX(sv) != 0; /* casts to bool */ | |
633 | ||
634 | if (SvROK(sv) && !(SvOBJECT(SvRV(sv)) && HvAMAGIC(SvSTASH(SvRV(sv))))) | |
635 | return TRUE; | |
636 | ||
637 | if (sv_2bool_is_fallback) | |
638 | return sv_2bool_nomg(sv); | |
639 | ||
640 | return isGV_with_GP(sv); | |
641 | } | |
642 | ||
643 | PERL_STATIC_INLINE SV * | |
644 | Perl_SvREFCNT_inc(SV *sv) | |
645 | { | |
646 | if (LIKELY(sv != NULL)) | |
647 | SvREFCNT(sv)++; | |
648 | return sv; | |
649 | } | |
650 | PERL_STATIC_INLINE SV * | |
651 | Perl_SvREFCNT_inc_NN(SV *sv) | |
652 | { | |
653 | PERL_ARGS_ASSERT_SVREFCNT_INC_NN; | |
654 | ||
655 | SvREFCNT(sv)++; | |
656 | return sv; | |
657 | } | |
658 | PERL_STATIC_INLINE void | |
659 | Perl_SvREFCNT_inc_void(SV *sv) | |
660 | { | |
661 | if (LIKELY(sv != NULL)) | |
662 | SvREFCNT(sv)++; | |
663 | } | |
664 | PERL_STATIC_INLINE void | |
665 | Perl_SvREFCNT_dec(pTHX_ SV *sv) | |
666 | { | |
667 | if (LIKELY(sv != NULL)) { | |
668 | U32 rc = SvREFCNT(sv); | |
669 | if (LIKELY(rc > 1)) | |
670 | SvREFCNT(sv) = rc - 1; | |
671 | else | |
672 | Perl_sv_free2(aTHX_ sv, rc); | |
673 | } | |
674 | } | |
675 | ||
676 | PERL_STATIC_INLINE void | |
677 | Perl_SvREFCNT_dec_NN(pTHX_ SV *sv) | |
678 | { | |
679 | U32 rc = SvREFCNT(sv); | |
680 | ||
681 | PERL_ARGS_ASSERT_SVREFCNT_DEC_NN; | |
682 | ||
683 | if (LIKELY(rc > 1)) | |
684 | SvREFCNT(sv) = rc - 1; | |
685 | else | |
686 | Perl_sv_free2(aTHX_ sv, rc); | |
687 | } | |
688 | ||
689 | /* | |
690 | =for apidoc SvAMAGIC_on | |
691 | ||
692 | Indicate that C<sv> has overloading (active magic) enabled. | |
693 | ||
694 | =cut | |
695 | */ | |
696 | ||
697 | PERL_STATIC_INLINE void | |
698 | Perl_SvAMAGIC_on(SV *sv) | |
699 | { | |
700 | PERL_ARGS_ASSERT_SVAMAGIC_ON; | |
701 | assert(SvROK(sv)); | |
702 | ||
703 | if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv))); | |
704 | } | |
705 | ||
706 | /* | |
707 | =for apidoc SvAMAGIC_off | |
708 | ||
709 | Indicate that C<sv> has overloading (active magic) disabled. | |
710 | ||
711 | =cut | |
712 | */ | |
713 | ||
714 | PERL_STATIC_INLINE void | |
715 | Perl_SvAMAGIC_off(SV *sv) | |
716 | { | |
717 | PERL_ARGS_ASSERT_SVAMAGIC_OFF; | |
718 | ||
719 | if (SvROK(sv) && SvOBJECT(SvRV(sv))) | |
720 | HvAMAGIC_off(SvSTASH(SvRV(sv))); | |
721 | } | |
722 | ||
723 | PERL_STATIC_INLINE U32 | |
724 | Perl_SvPADSTALE_on(SV *sv) | |
725 | { | |
726 | assert(!(SvFLAGS(sv) & SVs_PADTMP)); | |
727 | return SvFLAGS(sv) |= SVs_PADSTALE; | |
728 | } | |
729 | PERL_STATIC_INLINE U32 | |
730 | Perl_SvPADSTALE_off(SV *sv) | |
731 | { | |
732 | assert(!(SvFLAGS(sv) & SVs_PADTMP)); | |
733 | return SvFLAGS(sv) &= ~SVs_PADSTALE; | |
734 | } | |
735 | ||
736 | /* | |
737 | =for apidoc_section $SV | |
1607e393 | 738 | =for apidoc SvIV |
2356f8bb | 739 | =for apidoc_item SvIV_nomg |
1607e393 | 740 | =for apidoc_item SvIVx |
2356f8bb RL |
741 | |
742 | These each coerce the given SV to IV and return it. The returned value in many | |
743 | circumstances will get stored in C<sv>'s IV slot, but not in all cases. (Use | |
744 | C<L</sv_setiv>> to make sure it does). | |
745 | ||
746 | As of 5.37.1, all are guaranteed to evaluate C<sv> only once. | |
747 | ||
748 | C<SvIVx> is now identical to C<SvIV>, but prior to 5.37.1, it was the only form | |
749 | guaranteed to evaluate C<sv> only once. | |
750 | ||
751 | C<SvIV_nomg> is the same as C<SvIV>, but does not perform 'get' magic. | |
752 | ||
1607e393 | 753 | =for apidoc SvNV |
2356f8bb | 754 | =for apidoc_item SvNV_nomg |
1607e393 | 755 | =for apidoc_item SvNVx |
2356f8bb RL |
756 | |
757 | These each coerce the given SV to NV and return it. The returned value in many | |
758 | circumstances will get stored in C<sv>'s NV slot, but not in all cases. (Use | |
759 | C<L</sv_setnv>> to make sure it does). | |
760 | ||
761 | As of 5.37.1, all are guaranteed to evaluate C<sv> only once. | |
762 | ||
763 | C<SvNVx> is now identical to C<SvNV>, but prior to 5.37.1, it was the only form | |
764 | guaranteed to evaluate C<sv> only once. | |
765 | ||
766 | C<SvNV_nomg> is the same as C<SvNV>, but does not perform 'get' magic. | |
767 | ||
1607e393 | 768 | =for apidoc SvUV |
2356f8bb | 769 | =for apidoc_item SvUV_nomg |
1607e393 | 770 | =for apidoc_item SvUVx |
2356f8bb RL |
771 | |
772 | These each coerce the given SV to UV and return it. The returned value in many | |
773 | circumstances will get stored in C<sv>'s UV slot, but not in all cases. (Use | |
774 | C<L</sv_setuv>> to make sure it does). | |
775 | ||
776 | As of 5.37.1, all are guaranteed to evaluate C<sv> only once. | |
777 | ||
778 | C<SvUVx> is now identical to C<SvUV>, but prior to 5.37.1, it was the only form | |
779 | guaranteed to evaluate C<sv> only once. | |
780 | ||
781 | =cut | |
782 | */ | |
783 | ||
784 | PERL_STATIC_INLINE IV | |
785 | Perl_SvIV(pTHX_ SV *sv) { | |
786 | PERL_ARGS_ASSERT_SVIV; | |
787 | ||
788 | if (SvIOK_nog(sv)) | |
789 | return SvIVX(sv); | |
790 | return sv_2iv(sv); | |
791 | } | |
792 | ||
793 | PERL_STATIC_INLINE UV | |
794 | Perl_SvUV(pTHX_ SV *sv) { | |
795 | PERL_ARGS_ASSERT_SVUV; | |
796 | ||
797 | if (SvUOK_nog(sv)) | |
798 | return SvUVX(sv); | |
799 | return sv_2uv(sv); | |
800 | } | |
801 | ||
802 | PERL_STATIC_INLINE NV | |
803 | Perl_SvNV(pTHX_ SV *sv) { | |
804 | PERL_ARGS_ASSERT_SVNV; | |
805 | ||
806 | if (SvNOK_nog(sv)) | |
807 | return SvNVX(sv); | |
808 | return sv_2nv(sv); | |
809 | } | |
810 | ||
811 | PERL_STATIC_INLINE IV | |
812 | Perl_SvIV_nomg(pTHX_ SV *sv) { | |
813 | PERL_ARGS_ASSERT_SVIV_NOMG; | |
814 | ||
815 | if (SvIOK(sv)) | |
816 | return SvIVX(sv); | |
817 | return sv_2iv_flags(sv, 0); | |
818 | } | |
819 | ||
820 | PERL_STATIC_INLINE UV | |
821 | Perl_SvUV_nomg(pTHX_ SV *sv) { | |
822 | PERL_ARGS_ASSERT_SVUV_NOMG; | |
823 | ||
824 | if (SvIOK_nog(sv)) | |
825 | return SvUVX(sv); | |
826 | return sv_2uv_flags(sv, 0); | |
827 | } | |
828 | ||
829 | PERL_STATIC_INLINE NV | |
830 | Perl_SvNV_nomg(pTHX_ SV *sv) { | |
831 | PERL_ARGS_ASSERT_SVNV_NOMG; | |
832 | ||
833 | if (SvNOK_nog(sv)) | |
834 | return SvNVX(sv); | |
835 | return sv_2nv_flags(sv, 0); | |
836 | } | |
837 | ||
838 | #if defined(PERL_CORE) || defined (PERL_EXT) | |
839 | PERL_STATIC_INLINE STRLEN | |
840 | S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp) | |
841 | { | |
842 | PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B; | |
843 | if (SvGAMAGIC(sv)) { | |
844 | U8 *hopped = utf8_hop((U8 *)pv, pos); | |
845 | if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped); | |
846 | return (STRLEN)(hopped - (U8 *)pv); | |
847 | } | |
848 | return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN); | |
849 | } | |
850 | #endif | |
851 | ||
1ef9039b | 852 | PERL_STATIC_INLINE char * |
40917323 KW |
853 | Perl_sv_pvutf8n_force_wrapper(pTHX_ SV * const sv, STRLEN * const lp, const U32 dummy) |
854 | { | |
855 | /* This is just so can be passed to Perl_SvPV_helper() as a function | |
856 | * pointer with the same signature as all the other such pointers, and | |
857 | * having hence an unused parameter */ | |
858 | PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE_WRAPPER; | |
859 | PERL_UNUSED_ARG(dummy); | |
860 | ||
861 | return sv_pvutf8n_force(sv, lp); | |
862 | } | |
863 | ||
864 | PERL_STATIC_INLINE char * | |
865 | Perl_sv_pvbyten_force_wrapper(pTHX_ SV * const sv, STRLEN * const lp, const U32 dummy) | |
866 | { | |
867 | /* This is just so can be passed to Perl_SvPV_helper() as a function | |
868 | * pointer with the same signature as all the other such pointers, and | |
869 | * having hence an unused parameter */ | |
870 | PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE_WRAPPER; | |
871 | PERL_UNUSED_ARG(dummy); | |
872 | ||
873 | return sv_pvbyten_force(sv, lp); | |
874 | } | |
875 | ||
876 | PERL_STATIC_INLINE char * | |
1ef9039b KW |
877 | Perl_SvPV_helper(pTHX_ |
878 | SV * const sv, | |
879 | STRLEN * const lp, | |
880 | const U32 flags, | |
881 | const PL_SvPVtype type, | |
882 | char * (*non_trivial)(pTHX_ SV *, STRLEN * const, const U32), | |
883 | const bool or_null, | |
884 | const U32 return_flags | |
885 | ) | |
886 | { | |
887 | /* 'type' should be known at compile time, so this is reduced to a single | |
888 | * conditional at runtime */ | |
889 | if ( (type == SvPVbyte_type_ && SvPOK_byte_nog(sv)) | |
890 | || (type == SvPVforce_type_ && SvPOK_pure_nogthink(sv)) | |
891 | || (type == SvPVutf8_type_ && SvPOK_utf8_nog(sv)) | |
892 | || (type == SvPVnormal_type_ && SvPOK_nog(sv)) | |
893 | || (type == SvPVutf8_pure_type_ && SvPOK_utf8_pure_nogthink(sv)) | |
894 | || (type == SvPVbyte_pure_type_ && SvPOK_byte_pure_nogthink(sv)) | |
895 | ) { | |
896 | if (lp) { | |
897 | *lp = SvCUR(sv); | |
898 | } | |
899 | ||
900 | /* Similarly 'return_flags is known at compile time, so this becomes | |
901 | * branchless */ | |
902 | if (return_flags & SV_MUTABLE_RETURN) { | |
903 | return SvPVX_mutable(sv); | |
904 | } | |
905 | else if(return_flags & SV_CONST_RETURN) { | |
906 | return (char *) SvPVX_const(sv); | |
907 | } | |
908 | else { | |
909 | return SvPVX(sv); | |
910 | } | |
911 | } | |
912 | ||
913 | if (or_null) { /* This is also known at compile time */ | |
914 | if (flags & SV_GMAGIC) { /* As is this */ | |
915 | SvGETMAGIC(sv); | |
916 | } | |
917 | ||
918 | if (! SvOK(sv)) { | |
919 | if (lp) { /* As is this */ | |
920 | *lp = 0; | |
921 | } | |
922 | ||
923 | return NULL; | |
924 | } | |
925 | } | |
926 | ||
927 | /* Can't trivially handle this, call the function */ | |
928 | return non_trivial(aTHX_ sv, lp, (flags|return_flags)); | |
929 | } | |
930 | ||
7ea8b04b | 931 | /* |
819d09b5 RL |
932 | =for apidoc newRV_noinc |
933 | ||
934 | Creates an RV wrapper for an SV. The reference count for the original | |
935 | SV is B<not> incremented. | |
936 | ||
937 | =cut | |
938 | */ | |
939 | ||
940 | PERL_STATIC_INLINE SV * | |
941 | Perl_newRV_noinc(pTHX_ SV *const tmpRef) | |
942 | { | |
943 | SV *sv = newSV_type(SVt_IV); | |
944 | ||
945 | PERL_ARGS_ASSERT_NEWRV_NOINC; | |
946 | ||
947 | SvTEMP_off(tmpRef); | |
948 | ||
949 | /* inlined, simplified sv_setrv_noinc(sv, tmpRef); */ | |
950 | SvRV_set(sv, tmpRef); | |
951 | SvROK_on(sv); | |
952 | ||
953 | return sv; | |
954 | } | |
955 | ||
956 | /* | |
75acd14e RL |
957 | * ex: set ts=8 sts=4 sw=4 et: |
958 | */ |