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