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 : 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 /* 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 530 /* 531 * ex: set ts=8 sts=4 sw=4 et: 532 */ 533