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 : 5;        /* We have space for a sanity check. */
 129     PERL_BITFIELD8 cant_upgrade : 1;/* Cannot upgrade this type */
 130     PERL_BITFIELD8 zero_nv : 1;     /* zero the NV when upgrading from this */
 131     PERL_BITFIELD8 arena : 1;       /* Allocated from an arena */
 132     U32 arena_size;                 /* Size of arena to allocate */
 133 };
 134
 135 #define ALIGNED_TYPE_NAME(name) name##_aligned
 136 #define ALIGNED_TYPE(name)             \
 137     typedef union {    \
 138         name align_me;                         \
 139         NV nv;                         \
 140         IV iv;                         \
 141     } ALIGNED_TYPE_NAME(name)
 142
 143 ALIGNED_TYPE(regexp);
 144 ALIGNED_TYPE(XPVGV);
 145 ALIGNED_TYPE(XPVLV);
 146 ALIGNED_TYPE(XPVAV);
 147 ALIGNED_TYPE(XPVHV);
 148 ALIGNED_TYPE(XPVHV_WITH_AUX);
 149 ALIGNED_TYPE(XPVCV);
 150 ALIGNED_TYPE(XPVFM);
 151 ALIGNED_TYPE(XPVIO);
 152 ALIGNED_TYPE(XPVOBJ);
 153
 154 #define HADNV FALSE
 155 #define NONV TRUE
 156
 157
 158 #ifdef PURIFY
 159 /* With -DPURFIY we allocate everything directly, and don't use arenas.
 160    This seems a rather elegant way to simplify some of the code below.  */
 161 #define HASARENA FALSE
 162 #else
 163 #define HASARENA TRUE
 164 #endif
 165 #define NOARENA FALSE
 166
 167 /* Size the arenas to exactly fit a given number of bodies.  A count
 168    of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
 169    simplifying the default.  If count > 0, the arena is sized to fit
 170    only that many bodies, allowing arenas to be used for large, rare
 171    bodies (XPVFM, XPVIO) without undue waste.  The arena size is
 172    limited by PERL_ARENA_SIZE, so we can safely oversize the
 173    declarations.
 174  */
 175 #define FIT_ARENA0(body_size)                          \
 176     ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
 177 #define FIT_ARENAn(count,body_size)                    \
 178     ( count * body_size <= PERL_ARENA_SIZE)            \
 179     ? count * body_size                                        \
 180     : FIT_ARENA0 (body_size)
 181 #define FIT_ARENA(count,body_size)                     \
 182    (U32)(count                                                 \
 183     ? FIT_ARENAn (count, body_size)                    \
 184     : FIT_ARENA0 (body_size))
 185
 186 /* Calculate the length to copy. Specifically work out the length less any
 187    final padding the compiler needed to add.  See the comment in sv_upgrade
 188    for why copying the padding proved to be a bug.  */
 189
 190 #define copy_length(type, last_member) \
 191         STRUCT_OFFSET(type, last_member) \
 192         + sizeof (((type*)SvANY((const SV *)0))->last_member)
 193
 194 static const struct body_details bodies_by_type[] = {
 195     /* HEs use this offset for their arena.  */
 196     { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
 197
 198     /* IVs are in the head, so the allocation size is 0.  */
 199     { 0,
 200       sizeof(IV), /* This is used to copy out the IV body.  */
 201       STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
 202       NOARENA /* IVS don't need an arena  */, 0
 203     },
 204
 205 #if NVSIZE <= IVSIZE
 206     { 0, sizeof(NV),
 207       STRUCT_OFFSET(XPVNV, xnv_u),
 208       SVt_NV, FALSE, HADNV, NOARENA, 0 },
 209 #else
 210     { sizeof(NV), sizeof(NV),
 211       STRUCT_OFFSET(XPVNV, xnv_u),
 212       SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
 213 #endif
 214
 215     { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
 216       copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
 217       + STRUCT_OFFSET(XPV, xpv_cur),
 218       SVt_PV, FALSE, NONV, HASARENA,
 219       FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
 220
 221     { sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur),
 222       copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur),
 223       + STRUCT_OFFSET(XPV, xpv_cur),
 224       SVt_INVLIST, TRUE, NONV, HASARENA,
 225       FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)) },
 226
 227     { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
 228       copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
 229       + STRUCT_OFFSET(XPV, xpv_cur),
 230       SVt_PVIV, FALSE, NONV, HASARENA,
 231       FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
 232
 233     { 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))) },
 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))) },
 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:
 400     case SVt_PVOBJ:
 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
 420         switch(type) {
 421         case SVt_PVAV:
 422             AvFILLp(sv) = -1;
 423             AvMAX(sv) = -1;
 424             AvALLOC(sv) = NULL;
 425
 426             AvREAL_only(sv);
 427             break;
 428         case SVt_PVHV:
 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;
 440             break;
 441         case SVt_PVOBJ:
 442             ObjectMAXFIELD(sv) = -1;
 443             ObjectFIELDS(sv) = NULL;
 444             break;
 445         default:
 446             NOT_REACHED;
 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 /*
 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
 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
 570     PERL_UNUSED_CONTEXT;
 571
 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
 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
 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 }
 669
 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 }
 678
 679 PERL_STATIC_INLINE void
 680 Perl_SvREFCNT_inc_void(SV *sv)
 681 {
 682     if (LIKELY(sv != NULL))
 683         SvREFCNT(sv)++;
 684 }
 685
 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
 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
 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
 769 =for apidoc      SvIV
 770 =for apidoc_item SvIV_nomg
 771 =for apidoc_item SvIVx
 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
 784 =for apidoc      SvNV
 785 =for apidoc_item SvNV_nomg
 786 =for apidoc_item SvNVx
 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
 799 =for apidoc      SvUV
 800 =for apidoc_item SvUV_nomg
 801 =for apidoc_item SvUVx
 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
 883 PERL_STATIC_INLINE char *
 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 *
 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
 962 /*
 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
 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
1002 /*
1003  * ex: set ts=8 sts=4 sw=4 et:
1004  */