sv_inline.h

   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 /* 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
 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
 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
 738 =for apidoc      SvIV
 739 =for apidoc_item SvIV_nomg
 740 =for apidoc_item SvIVx
 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
 753 =for apidoc      SvNV
 754 =for apidoc_item SvNV_nomg
 755 =for apidoc_item SvNVx
 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
 768 =for apidoc      SvUV
 769 =for apidoc_item SvUV_nomg
 770 =for apidoc_item SvUVx
 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
 852 PERL_STATIC_INLINE char *
 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 *
 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
 931 /*
 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 /*
 957  * ex: set ts=8 sts=4 sw=4 et:
 958  */