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