inline.h

   1 /*    inline.h
   2  *
   3  *    Copyright (C) 2012 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  * This file is a home for static inline functions that cannot go in other
   9  * headers files, because they depend on proto.h (included after most other
  10  * headers) or struct definitions.
  11  *
  12  * Each section names the header file that the functions "belong" to.
  13  */
  14
  15 /* ------------------------------- av.h ------------------------------- */
  16
  17 PERL_STATIC_INLINE SSize_t
  18 S_av_top_index(pTHX_ AV *av)
  19 {
  20     PERL_ARGS_ASSERT_AV_TOP_INDEX;
  21     assert(SvTYPE(av) == SVt_PVAV);
  22
  23     return AvFILL(av);
  24 }
  25
  26 /* ------------------------------- cv.h ------------------------------- */
  27
  28 PERL_STATIC_INLINE GV *
  29 S_CvGV(pTHX_ CV *sv)
  30 {
  31     return CvNAMED(sv)
  32         ? Perl_cvgv_from_hek(aTHX_ sv)
  33         : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
  34 }
  35
  36 PERL_STATIC_INLINE I32 *
  37 S_CvDEPTHp(const CV * const sv)
  38 {
  39     assert(SvTYPE(sv) == SVt_PVCV || SvTYPE(sv) == SVt_PVFM);
  40     return &((XPVCV*)SvANY(sv))->xcv_depth;
  41 }
  42
  43 /*
  44  CvPROTO returns the prototype as stored, which is not necessarily what
  45  the interpreter should be using. Specifically, the interpreter assumes
  46  that spaces have been stripped, which has been the case if the prototype
  47  was added by toke.c, but is generally not the case if it was added elsewhere.
  48  Since we can't enforce the spacelessness at assignment time, this routine
  49  provides a temporary copy at parse time with spaces removed.
  50  I<orig> is the start of the original buffer, I<len> is the length of the
  51  prototype and will be updated when this returns.
  52  */
  53
  54 #ifdef PERL_CORE
  55 PERL_STATIC_INLINE char *
  56 S_strip_spaces(pTHX_ const char * orig, STRLEN * const len)
  57 {
  58     SV * tmpsv;
  59     char * tmps;
  60     tmpsv = newSVpvn_flags(orig, *len, SVs_TEMP);
  61     tmps = SvPVX(tmpsv);
  62     while ((*len)--) {
  63         if (!isSPACE(*orig))
  64             *tmps++ = *orig;
  65         orig++;
  66     }
  67     *tmps = '\0';
  68     *len = tmps - SvPVX(tmpsv);
  69                 return SvPVX(tmpsv);
  70 }
  71 #endif
  72
  73 /* ------------------------------- mg.h ------------------------------- */
  74
  75 #if defined(PERL_CORE) || defined(PERL_EXT)
  76 /* assumes get-magic and stringification have already occurred */
  77 PERL_STATIC_INLINE STRLEN
  78 S_MgBYTEPOS(pTHX_ MAGIC *mg, SV *sv, const char *s, STRLEN len)
  79 {
  80     assert(mg->mg_type == PERL_MAGIC_regex_global);
  81     assert(mg->mg_len != -1);
  82     if (mg->mg_flags & MGf_BYTES || !DO_UTF8(sv))
  83         return (STRLEN)mg->mg_len;
  84     else {
  85         const STRLEN pos = (STRLEN)mg->mg_len;
  86         /* Without this check, we may read past the end of the buffer: */
  87         if (pos > sv_or_pv_len_utf8(sv, s, len)) return len+1;
  88         return sv_or_pv_pos_u2b(sv, s, pos, NULL);
  89     }
  90 }
  91 #endif
  92
  93 /* ------------------------------- pad.h ------------------------------ */
  94
  95 #if defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
  96 PERL_STATIC_INLINE bool
  97 PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
  98 {
  99     /* is seq within the range _LOW to _HIGH ?
 100      * This is complicated by the fact that PL_cop_seqmax
 101      * may have wrapped around at some point */
 102     if (COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO)
 103         return FALSE; /* not yet introduced */
 104
 105     if (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO) {
 106     /* in compiling scope */
 107         if (
 108             (seq >  COP_SEQ_RANGE_LOW(pn))
 109             ? (seq - COP_SEQ_RANGE_LOW(pn) < (U32_MAX >> 1))
 110             : (COP_SEQ_RANGE_LOW(pn) - seq > (U32_MAX >> 1))
 111         )
 112             return TRUE;
 113     }
 114     else if (
 115         (COP_SEQ_RANGE_LOW(pn) > COP_SEQ_RANGE_HIGH(pn))
 116         ?
 117             (  seq >  COP_SEQ_RANGE_LOW(pn)
 118             || seq <= COP_SEQ_RANGE_HIGH(pn))
 119
 120         :    (  seq >  COP_SEQ_RANGE_LOW(pn)
 121              && seq <= COP_SEQ_RANGE_HIGH(pn))
 122     )
 123         return TRUE;
 124     return FALSE;
 125 }
 126 #endif
 127
 128 /* ------------------------------- pp.h ------------------------------- */
 129
 130 PERL_STATIC_INLINE I32
 131 S_TOPMARK(pTHX)
 132 {
 133     DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
 134                                  "MARK top  %p %"IVdf"\n",
 135                                   PL_markstack_ptr,
 136                                   (IV)*PL_markstack_ptr)));
 137     return *PL_markstack_ptr;
 138 }
 139
 140 PERL_STATIC_INLINE I32
 141 S_POPMARK(pTHX)
 142 {
 143     DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
 144                                  "MARK pop  %p %"IVdf"\n",
 145                                   (PL_markstack_ptr-1),
 146                                   (IV)*(PL_markstack_ptr-1))));
 147     assert((PL_markstack_ptr > PL_markstack) || !"MARK underflow");
 148     return *PL_markstack_ptr--;
 149 }
 150
 151 /* ----------------------------- regexp.h ----------------------------- */
 152
 153 PERL_STATIC_INLINE struct regexp *
 154 S_ReANY(const REGEXP * const re)
 155 {
 156     assert(isREGEXP(re));
 157     return re->sv_u.svu_rx;
 158 }
 159
 160 /* ------------------------------- sv.h ------------------------------- */
 161
 162 PERL_STATIC_INLINE SV *
 163 S_SvREFCNT_inc(SV *sv)
 164 {
 165     if (LIKELY(sv != NULL))
 166         SvREFCNT(sv)++;
 167     return sv;
 168 }
 169 PERL_STATIC_INLINE SV *
 170 S_SvREFCNT_inc_NN(SV *sv)
 171 {
 172     SvREFCNT(sv)++;
 173     return sv;
 174 }
 175 PERL_STATIC_INLINE void
 176 S_SvREFCNT_inc_void(SV *sv)
 177 {
 178     if (LIKELY(sv != NULL))
 179         SvREFCNT(sv)++;
 180 }
 181 PERL_STATIC_INLINE void
 182 S_SvREFCNT_dec(pTHX_ SV *sv)
 183 {
 184     if (LIKELY(sv != NULL)) {
 185         U32 rc = SvREFCNT(sv);
 186         if (LIKELY(rc > 1))
 187             SvREFCNT(sv) = rc - 1;
 188         else
 189             Perl_sv_free2(aTHX_ sv, rc);
 190     }
 191 }
 192
 193 PERL_STATIC_INLINE void
 194 S_SvREFCNT_dec_NN(pTHX_ SV *sv)
 195 {
 196     U32 rc = SvREFCNT(sv);
 197     if (LIKELY(rc > 1))
 198         SvREFCNT(sv) = rc - 1;
 199     else
 200         Perl_sv_free2(aTHX_ sv, rc);
 201 }
 202
 203 PERL_STATIC_INLINE void
 204 SvAMAGIC_on(SV *sv)
 205 {
 206     assert(SvROK(sv));
 207     if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
 208 }
 209 PERL_STATIC_INLINE void
 210 SvAMAGIC_off(SV *sv)
 211 {
 212     if (SvROK(sv) && SvOBJECT(SvRV(sv)))
 213         HvAMAGIC_off(SvSTASH(SvRV(sv)));
 214 }
 215
 216 PERL_STATIC_INLINE U32
 217 S_SvPADSTALE_on(SV *sv)
 218 {
 219     assert(!(SvFLAGS(sv) & SVs_PADTMP));
 220     return SvFLAGS(sv) |= SVs_PADSTALE;
 221 }
 222 PERL_STATIC_INLINE U32
 223 S_SvPADSTALE_off(SV *sv)
 224 {
 225     assert(!(SvFLAGS(sv) & SVs_PADTMP));
 226     return SvFLAGS(sv) &= ~SVs_PADSTALE;
 227 }
 228 #if defined(PERL_CORE) || defined (PERL_EXT)
 229 PERL_STATIC_INLINE STRLEN
 230 S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
 231 {
 232     PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
 233     if (SvGAMAGIC(sv)) {
 234         U8 *hopped = utf8_hop((U8 *)pv, pos);
 235         if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);
 236         return (STRLEN)(hopped - (U8 *)pv);
 237     }
 238     return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN);
 239 }
 240 #endif
 241
 242 /* ------------------------------- handy.h ------------------------------- */
 243
 244 /* saves machine code for a common noreturn idiom typically used in Newx*() */
 245 #ifdef GCC_DIAG_PRAGMA
 246 GCC_DIAG_IGNORE(-Wunused-function) /* Intentionally left semicolonless. */
 247 #endif
 248 static void
 249 S_croak_memory_wrap(void)
 250 {
 251     Perl_croak_nocontext("%s",PL_memory_wrap);
 252 }
 253 #ifdef GCC_DIAG_PRAGMA
 254 GCC_DIAG_RESTORE /* Intentionally left semicolonless. */
 255 #endif
 256
 257 /* ------------------------------- utf8.h ------------------------------- */
 258
 259 /*
 260 =head1 Unicode Support
 261 */
 262
 263 PERL_STATIC_INLINE void
 264 S_append_utf8_from_native_byte(const U8 byte, U8** dest)
 265 {
 266     /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
 267      * encoded string at '*dest', updating '*dest' to include it */
 268
 269     PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
 270
 271     if (NATIVE_BYTE_IS_INVARIANT(byte))
 272         *(*dest)++ = byte;
 273     else {
 274         *(*dest)++ = UTF8_EIGHT_BIT_HI(byte);
 275         *(*dest)++ = UTF8_EIGHT_BIT_LO(byte);
 276     }
 277 }
 278
 279 /*
 280 =for apidoc valid_utf8_to_uvchr
 281 Like L</utf8_to_uvchr_buf>(), but should only be called when it is known that
 282 the next character in the input UTF-8 string C<s> is well-formed (I<e.g.>,
 283 it passes C<L</isUTF8_CHAR>>.  Surrogates, non-character code points, and
 284 non-Unicode code points are allowed.
 285
 286 =cut
 287
 288  */
 289
 290 PERL_STATIC_INLINE UV
 291 Perl_valid_utf8_to_uvchr(const U8 *s, STRLEN *retlen)
 292 {
 293     UV expectlen = UTF8SKIP(s);
 294     const U8* send = s + expectlen;
 295     UV uv = *s;
 296
 297     PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
 298
 299     if (retlen) {
 300         *retlen = expectlen;
 301     }
 302
 303     /* An invariant is trivially returned */
 304     if (expectlen == 1) {
 305         return uv;
 306     }
 307
 308     /* Remove the leading bits that indicate the number of bytes, leaving just
 309      * the bits that are part of the value */
 310     uv = NATIVE_UTF8_TO_I8(uv) & UTF_START_MASK(expectlen);
 311
 312     /* Now, loop through the remaining bytes, accumulating each into the
 313      * working total as we go.  (I khw tried unrolling the loop for up to 4
 314      * bytes, but there was no performance improvement) */
 315     for (++s; s < send; s++) {
 316         uv = UTF8_ACCUMULATE(uv, *s);
 317     }
 318
 319     return UNI_TO_NATIVE(uv);
 320
 321 }
 322
 323 /*
 324 =for apidoc is_utf8_invariant_string
 325
 326 Returns true iff the first C<len> bytes of the string C<s> are the same
 327 regardless of the UTF-8 encoding of the string (or UTF-EBCDIC encoding on
 328 EBCDIC machines).  That is, if they are UTF-8 invariant.  On ASCII-ish
 329 machines, all the ASCII characters and only the ASCII characters fit this
 330 definition.  On EBCDIC machines, the ASCII-range characters are invariant, but
 331 so also are the C1 controls and C<\c?> (which isn't in the ASCII range on
 332 EBCDIC).
 333
 334 If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you
 335 use this option, that C<s> can't have embedded C<NUL> characters and has to
 336 have a terminating C<NUL> byte).
 337
 338 See also L</is_utf8_string>(), L</is_utf8_string_loclen>(), and
 339 L</is_utf8_string_loc>().
 340
 341 =cut
 342 */
 343
 344 PERL_STATIC_INLINE bool
 345 S_is_utf8_invariant_string(const U8* const s, const STRLEN len)
 346 {
 347     const U8* const send = s + (len ? len : strlen((const char *)s));
 348     const U8* x = s;
 349
 350     PERL_ARGS_ASSERT_IS_UTF8_INVARIANT_STRING;
 351
 352     for (; x < send; ++x) {
 353         if (!UTF8_IS_INVARIANT(*x))
 354             return FALSE;
 355     }
 356
 357     return TRUE;
 358 }
 359
 360 /*
 361 =for apidoc is_utf8_string
 362
 363 Returns true if the first C<len> bytes of string C<s> form a valid
 364 UTF-8 string, false otherwise.  If C<len> is 0, it will be calculated
 365 using C<strlen(s)> (which means if you use this option, that C<s> can't have
 366 embedded C<NUL> characters and has to have a terminating C<NUL> byte).  Note
 367 that all characters being ASCII constitute 'a valid UTF-8 string'.
 368
 369 See also L</is_utf8_invariant_string>(), L</is_utf8_string_loclen>(), and
 370 L</is_utf8_string_loc>().
 371
 372 =cut
 373 */
 374
 375 bool
 376 Perl_is_utf8_string(const U8 *s, STRLEN len)
 377 {
 378     const U8* const send = s + (len ? len : strlen((const char *)s));
 379     const U8* x = s;
 380
 381     PERL_ARGS_ASSERT_IS_UTF8_STRING;
 382
 383     while (x < send) {
 384         STRLEN len = isUTF8_CHAR(x, send);
 385         if (UNLIKELY(! len)) {
 386             return FALSE;
 387         }
 388         x += len;
 389     }
 390
 391     return TRUE;
 392 }
 393
 394 /*
 395 Implemented as a macro in utf8.h
 396
 397 =for apidoc is_utf8_string_loc
 398
 399 Like L</is_utf8_string> but stores the location of the failure (in the
 400 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
 401 "utf8ness success") in the C<ep>.
 402
 403 See also L</is_utf8_string_loclen>() and L</is_utf8_string>().
 404
 405 =for apidoc is_utf8_string_loclen
 406
 407 Like L</is_utf8_string>() but stores the location of the failure (in the
 408 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
 409 "utf8ness success") in the C<ep>, and the number of UTF-8
 410 encoded characters in the C<el>.
 411
 412 See also L</is_utf8_string_loc>() and L</is_utf8_string>().
 413
 414 =cut
 415 */
 416
 417 bool
 418 Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
 419 {
 420     const U8* const send = s + (len ? len : strlen((const char *)s));
 421     const U8* x = s;
 422     STRLEN outlen = 0;
 423
 424     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
 425
 426     while (x < send) {
 427         STRLEN len = isUTF8_CHAR(x, send);
 428         if (UNLIKELY(! len)) {
 429             break;
 430         }
 431         x += len;
 432         outlen++;
 433     }
 434
 435     if (el)
 436         *el = outlen;
 437
 438     if (ep) {
 439         *ep = x;
 440     }
 441
 442     return (x == send);
 443 }
 444
 445 /*
 446 =for apidoc utf8_distance
 447
 448 Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
 449 and C<b>.
 450
 451 WARNING: use only if you *know* that the pointers point inside the
 452 same UTF-8 buffer.
 453
 454 =cut
 455 */
 456
 457 PERL_STATIC_INLINE IV
 458 Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
 459 {
 460     PERL_ARGS_ASSERT_UTF8_DISTANCE;
 461
 462     return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
 463 }
 464
 465 /*
 466 =for apidoc utf8_hop
 467
 468 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
 469 forward or backward.
 470
 471 WARNING: do not use the following unless you *know* C<off> is within
 472 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
 473 on the first byte of character or just after the last byte of a character.
 474
 475 =cut
 476 */
 477
 478 PERL_STATIC_INLINE U8 *
 479 Perl_utf8_hop(const U8 *s, SSize_t off)
 480 {
 481     PERL_ARGS_ASSERT_UTF8_HOP;
 482
 483     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
 484      * the bitops (especially ~) can create illegal UTF-8.
 485      * In other words: in Perl UTF-8 is not just for Unicode. */
 486
 487     if (off >= 0) {
 488         while (off--)
 489             s += UTF8SKIP(s);
 490     }
 491     else {
 492         while (off++) {
 493             s--;
 494             while (UTF8_IS_CONTINUATION(*s))
 495                 s--;
 496         }
 497     }
 498     return (U8 *)s;
 499 }
 500
 501 /* ------------------------------- perl.h ----------------------------- */
 502
 503 /*
 504 =head1 Miscellaneous Functions
 505
 506 =for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
 507
 508 Test that the given C<pv> doesn't contain any internal C<NUL> characters.
 509 If it does, set C<errno> to C<ENOENT>, optionally warn, and return FALSE.
 510
 511 Return TRUE if the name is safe.
 512
 513 Used by the C<IS_SAFE_SYSCALL()> macro.
 514
 515 =cut
 516 */
 517
 518 PERL_STATIC_INLINE bool
 519 S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
 520     /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
 521      * perl itself uses xce*() functions which accept 8-bit strings.
 522      */
 523
 524     PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
 525
 526     if (len > 1) {
 527         char *null_at;
 528         if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
 529                 SETERRNO(ENOENT, LIB_INVARG);
 530                 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
 531                                    "Invalid \\0 character in %s for %s: %s\\0%s",
 532                                    what, op_name, pv, null_at+1);
 533                 return FALSE;
 534         }
 535     }
 536
 537     return TRUE;
 538 }
 539
 540 /*
 541
 542 Return true if the supplied filename has a newline character
 543 immediately before the first (hopefully only) NUL.
 544
 545 My original look at this incorrectly used the len from SvPV(), but
 546 that's incorrect, since we allow for a NUL in pv[len-1].
 547
 548 So instead, strlen() and work from there.
 549
 550 This allow for the user reading a filename, forgetting to chomp it,
 551 then calling:
 552
 553   open my $foo, "$file\0";
 554
 555 */
 556
 557 #ifdef PERL_CORE
 558
 559 PERL_STATIC_INLINE bool
 560 S_should_warn_nl(const char *pv) {
 561     STRLEN len;
 562
 563     PERL_ARGS_ASSERT_SHOULD_WARN_NL;
 564
 565     len = strlen(pv);
 566
 567     return len > 0 && pv[len-1] == '\n';
 568 }
 569
 570 #endif
 571
 572 /* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
 573
 574 #define MAX_CHARSET_NAME_LENGTH 2
 575
 576 PERL_STATIC_INLINE const char *
 577 get_regex_charset_name(const U32 flags, STRLEN* const lenp)
 578 {
 579     /* Returns a string that corresponds to the name of the regex character set
 580      * given by 'flags', and *lenp is set the length of that string, which
 581      * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
 582
 583     *lenp = 1;
 584     switch (get_regex_charset(flags)) {
 585         case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
 586         case REGEX_LOCALE_CHARSET:  return LOCALE_PAT_MODS;
 587         case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
 588         case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
 589         case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
 590             *lenp = 2;
 591             return ASCII_MORE_RESTRICT_PAT_MODS;
 592     }
 593     /* The NOT_REACHED; hides an assert() which has a rather complex
 594      * definition in perl.h. */
 595     NOT_REACHED; /* NOTREACHED */
 596     return "?";     /* Unknown */
 597 }
 598
 599 /*
 600
 601 Return false if any get magic is on the SV other than taint magic.
 602
 603 */
 604
 605 PERL_STATIC_INLINE bool
 606 S_sv_only_taint_gmagic(SV *sv) {
 607     MAGIC *mg = SvMAGIC(sv);
 608
 609     PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
 610
 611     while (mg) {
 612         if (mg->mg_type != PERL_MAGIC_taint
 613             && !(mg->mg_flags & MGf_GSKIP)
 614             && mg->mg_virtual->svt_get) {
 615             return FALSE;
 616         }
 617         mg = mg->mg_moremagic;
 618     }
 619
 620     return TRUE;
 621 }
 622
 623 /* ------------------ cop.h ------------------------------------------- */
 624
 625
 626 /* Enter a block. Push a new base context and return its address. */
 627
 628 PERL_STATIC_INLINE PERL_CONTEXT *
 629 S_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
 630 {
 631     PERL_CONTEXT * cx;
 632
 633     PERL_ARGS_ASSERT_CX_PUSHBLOCK;
 634
 635     CXINC;
 636     cx = CX_CUR();
 637     cx->cx_type        = type;
 638     cx->blk_gimme      = gimme;
 639     cx->blk_oldsaveix  = saveix;
 640     cx->blk_oldsp      = (I32)(sp - PL_stack_base);
 641     cx->blk_oldcop     = PL_curcop;
 642     cx->blk_oldmarksp  = (I32)(PL_markstack_ptr - PL_markstack);
 643     cx->blk_oldscopesp = PL_scopestack_ix;
 644     cx->blk_oldpm      = PL_curpm;
 645     cx->blk_old_tmpsfloor = PL_tmps_floor;
 646
 647     PL_tmps_floor        = PL_tmps_ix;
 648     CX_DEBUG(cx, "PUSH");
 649     return cx;
 650 }
 651
 652
 653 /* Exit a block (RETURN and LAST). */
 654
 655 PERL_STATIC_INLINE void
 656 S_cx_popblock(pTHX_ PERL_CONTEXT *cx)
 657 {
 658     PERL_ARGS_ASSERT_CX_POPBLOCK;
 659
 660     CX_DEBUG(cx, "POP");
 661     /* these 3 are common to cx_popblock and cx_topblock */
 662     PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
 663     PL_scopestack_ix = cx->blk_oldscopesp;
 664     PL_curpm         = cx->blk_oldpm;
 665
 666     /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
 667      * and leaves a CX entry lying around for repeated use, so
 668      * skip for multicall */                  \
 669     assert(   (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
 670             || PL_savestack_ix == cx->blk_oldsaveix);
 671     PL_curcop     = cx->blk_oldcop;
 672     PL_tmps_floor = cx->blk_old_tmpsfloor;
 673 }
 674
 675 /* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
 676  * Whereas cx_popblock() restores the state to the point just before
 677  * cx_pushblock() was called,  cx_topblock() restores it to the point just
 678  * *after* cx_pushblock() was called. */
 679
 680 PERL_STATIC_INLINE void
 681 S_cx_topblock(pTHX_ PERL_CONTEXT *cx)
 682 {
 683     PERL_ARGS_ASSERT_CX_TOPBLOCK;
 684
 685     CX_DEBUG(cx, "TOP");
 686     /* these 3 are common to cx_popblock and cx_topblock */
 687     PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
 688     PL_scopestack_ix = cx->blk_oldscopesp;
 689     PL_curpm         = cx->blk_oldpm;
 690
 691     PL_stack_sp      = PL_stack_base + cx->blk_oldsp;
 692 }
 693
 694
 695 PERL_STATIC_INLINE void
 696 S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
 697 {
 698     U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
 699
 700     PERL_ARGS_ASSERT_CX_PUSHSUB;
 701
 702     PERL_DTRACE_PROBE_ENTRY(cv);
 703     cx->blk_sub.cv = cv;
 704     cx->blk_sub.olddepth = CvDEPTH(cv);
 705     cx->blk_sub.prevcomppad = PL_comppad;
 706     cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
 707     cx->blk_sub.retop = retop;
 708     SvREFCNT_inc_simple_void_NN(cv);
 709     cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
 710 }
 711
 712
 713 /* subsets of cx_popsub() */
 714
 715 PERL_STATIC_INLINE void
 716 S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
 717 {
 718     CV *cv;
 719
 720     PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
 721     assert(CxTYPE(cx) == CXt_SUB);
 722
 723     PL_comppad = cx->blk_sub.prevcomppad;
 724     PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
 725     cv = cx->blk_sub.cv;
 726     CvDEPTH(cv) = cx->blk_sub.olddepth;
 727     cx->blk_sub.cv = NULL;
 728     SvREFCNT_dec(cv);
 729 }
 730
 731
 732 /* handle the @_ part of leaving a sub */
 733
 734 PERL_STATIC_INLINE void
 735 S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
 736 {
 737     AV *av;
 738
 739     PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
 740     assert(CxTYPE(cx) == CXt_SUB);
 741     assert(AvARRAY(MUTABLE_AV(
 742         PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
 743                 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
 744
 745     CX_POP_SAVEARRAY(cx);
 746     av = MUTABLE_AV(PAD_SVl(0));
 747     if (UNLIKELY(AvREAL(av)))
 748         /* abandon @_ if it got reified */
 749         clear_defarray(av, 0);
 750     else {
 751         CLEAR_ARGARRAY(av);
 752     }
 753 }
 754
 755
 756 PERL_STATIC_INLINE void
 757 S_cx_popsub(pTHX_ PERL_CONTEXT *cx)
 758 {
 759     PERL_ARGS_ASSERT_CX_POPSUB;
 760     assert(CxTYPE(cx) == CXt_SUB);
 761
 762     PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
 763
 764     if (CxHASARGS(cx))
 765         cx_popsub_args(cx);
 766     cx_popsub_common(cx);
 767 }
 768
 769
 770 PERL_STATIC_INLINE void
 771 S_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
 772 {
 773     PERL_ARGS_ASSERT_CX_PUSHFORMAT;
 774
 775     cx->blk_format.cv          = cv;
 776     cx->blk_format.retop       = retop;
 777     cx->blk_format.gv          = gv;
 778     cx->blk_format.dfoutgv     = PL_defoutgv;
 779     cx->blk_format.prevcomppad = PL_comppad;
 780     cx->blk_u16                = 0;
 781
 782     SvREFCNT_inc_simple_void_NN(cv);
 783     CvDEPTH(cv)++;
 784     SvREFCNT_inc_void(cx->blk_format.dfoutgv);
 785 }
 786
 787
 788 PERL_STATIC_INLINE void
 789 S_cx_popformat(pTHX_ PERL_CONTEXT *cx)
 790 {
 791     CV *cv;
 792     GV *dfout;
 793
 794     PERL_ARGS_ASSERT_CX_POPFORMAT;
 795     assert(CxTYPE(cx) == CXt_FORMAT);
 796
 797     dfout = cx->blk_format.dfoutgv;
 798     setdefout(dfout);
 799     cx->blk_format.dfoutgv = NULL;
 800     SvREFCNT_dec_NN(dfout);
 801
 802     PL_comppad = cx->blk_format.prevcomppad;
 803     PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
 804     cv = cx->blk_format.cv;
 805     cx->blk_format.cv = NULL;
 806     --CvDEPTH(cv);
 807     SvREFCNT_dec_NN(cv);
 808 }
 809
 810
 811 PERL_STATIC_INLINE void
 812 S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
 813 {
 814     PERL_ARGS_ASSERT_CX_PUSHEVAL;
 815
 816     cx->blk_eval.retop         = retop;
 817     cx->blk_eval.old_namesv    = namesv;
 818     cx->blk_eval.old_eval_root = PL_eval_root;
 819     cx->blk_eval.cur_text      = PL_parser ? PL_parser->linestr : NULL;
 820     cx->blk_eval.cv            = NULL; /* later set by doeval_compile() */
 821     cx->blk_eval.cur_top_env   = PL_top_env;
 822
 823     assert(!(PL_in_eval     & ~ 0x7F));
 824     assert(!(PL_op->op_type & ~0x1FF));
 825     cx->blk_u16 = (PL_in_eval & 0x7F) | ((U16)PL_op->op_type << 7);
 826 }
 827
 828
 829 PERL_STATIC_INLINE void
 830 S_cx_popeval(pTHX_ PERL_CONTEXT *cx)
 831 {
 832     SV *sv;
 833
 834     PERL_ARGS_ASSERT_CX_POPEVAL;
 835     assert(CxTYPE(cx) == CXt_EVAL);
 836
 837     PL_in_eval = CxOLD_IN_EVAL(cx);
 838     PL_eval_root = cx->blk_eval.old_eval_root;
 839     sv = cx->blk_eval.cur_text;
 840     if (sv && SvSCREAM(sv)) {
 841         cx->blk_eval.cur_text = NULL;
 842         SvREFCNT_dec_NN(sv);
 843     }
 844
 845     sv = cx->blk_eval.old_namesv;
 846     if (sv) {
 847         cx->blk_eval.old_namesv = NULL;
 848         SvREFCNT_dec_NN(sv);
 849     }
 850 }
 851
 852
 853 /* push a plain loop, i.e.
 854  *     { block }
 855  *     while (cond) { block }
 856  *     for (init;cond;continue) { block }
 857  * This loop can be last/redo'ed etc.
 858  */
 859
 860 PERL_STATIC_INLINE void
 861 S_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
 862 {
 863     PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
 864     cx->blk_loop.my_op = cLOOP;
 865 }
 866
 867
 868 /* push a true for loop, i.e.
 869  *     for var (list) { block }
 870  */
 871
 872 PERL_STATIC_INLINE void
 873 S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
 874 {
 875     PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
 876
 877     /* this one line is common with cx_pushloop_plain */
 878     cx->blk_loop.my_op = cLOOP;
 879
 880     cx->blk_loop.itervar_u.svp = (SV**)itervarp;
 881     cx->blk_loop.itersave      = itersave;
 882 #ifdef USE_ITHREADS
 883     cx->blk_loop.oldcomppad = PL_comppad;
 884 #endif
 885 }
 886
 887
 888 /* pop all loop types, including plain */
 889
 890 PERL_STATIC_INLINE void
 891 S_cx_poploop(pTHX_ PERL_CONTEXT *cx)
 892 {
 893     PERL_ARGS_ASSERT_CX_POPLOOP;
 894
 895     assert(CxTYPE_is_LOOP(cx));
 896     if (  CxTYPE(cx) == CXt_LOOP_ARY
 897        || CxTYPE(cx) == CXt_LOOP_LAZYSV)
 898     {
 899         /* Free ary or cur. This assumes that state_u.ary.ary
 900          * aligns with state_u.lazysv.cur. See cx_dup() */
 901         SV *sv = cx->blk_loop.state_u.lazysv.cur;
 902         cx->blk_loop.state_u.lazysv.cur = NULL;
 903         SvREFCNT_dec_NN(sv);
 904         if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
 905             sv = cx->blk_loop.state_u.lazysv.end;
 906             cx->blk_loop.state_u.lazysv.end = NULL;
 907             SvREFCNT_dec_NN(sv);
 908         }
 909     }
 910     if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
 911         SV *cursv;
 912         SV **svp = (cx)->blk_loop.itervar_u.svp;
 913         if ((cx->cx_type & CXp_FOR_GV))
 914             svp = &GvSV((GV*)svp);
 915         cursv = *svp;
 916         *svp = cx->blk_loop.itersave;
 917         cx->blk_loop.itersave = NULL;
 918         SvREFCNT_dec(cursv);
 919     }
 920 }
 921
 922
 923 PERL_STATIC_INLINE void
 924 S_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
 925 {
 926     PERL_ARGS_ASSERT_CX_PUSHWHEN;
 927
 928     cx->blk_givwhen.leave_op = cLOGOP->op_other;
 929 }
 930
 931
 932 PERL_STATIC_INLINE void
 933 S_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
 934 {
 935     PERL_ARGS_ASSERT_CX_POPWHEN;
 936     assert(CxTYPE(cx) == CXt_WHEN);
 937
 938     PERL_UNUSED_ARG(cx);
 939     PERL_UNUSED_CONTEXT;
 940     /* currently NOOP */
 941 }
 942
 943
 944 PERL_STATIC_INLINE void
 945 S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
 946 {
 947     PERL_ARGS_ASSERT_CX_PUSHGIVEN;
 948
 949     cx->blk_givwhen.leave_op = cLOGOP->op_other;
 950     cx->blk_givwhen.defsv_save = orig_defsv;
 951 }
 952
 953
 954 PERL_STATIC_INLINE void
 955 S_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
 956 {
 957     SV *sv;
 958
 959     PERL_ARGS_ASSERT_CX_POPGIVEN;
 960     assert(CxTYPE(cx) == CXt_GIVEN);
 961
 962     sv = GvSV(PL_defgv);
 963     GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
 964     cx->blk_givwhen.defsv_save = NULL;
 965     SvREFCNT_dec(sv);
 966 }
 967
 968 /*
 969  * ex: set ts=8 sts=4 sw=4 et:
 970  */