cop.h

   1 /*    cop.h
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  * Control ops (cops) are one of the three ops OP_NEXTSTATE, OP_DBSTATE,
  10  * and OP_SETSTATE that (loosely speaking) are separate statements.
  11  * They hold information important for lexical state and error reporting.
  12  * At run time, PL_curcop is set to point to the most recently executed cop,
  13  * and thus can be used to determine our current state.
  14  */
  15
  16 /* A jmpenv packages the state required to perform a proper non-local jump.
  17  * Note that there is a start_env initialized when perl starts, and top_env
  18  * points to this initially, so top_env should always be non-null.
  19  *
  20  * Existence of a non-null top_env->je_prev implies it is valid to call
  21  * longjmp() at that runlevel (we make sure start_env.je_prev is always
  22  * null to ensure this).
  23  *
  24  * je_mustcatch, when set at any runlevel to TRUE, means eval ops must
  25  * establish a local jmpenv to handle exception traps.  Care must be taken
  26  * to restore the previous value of je_mustcatch before exiting the
  27  * stack frame iff JMPENV_PUSH was not called in that stack frame.
  28  * GSAR 97-03-27
  29  */
  30
  31 struct jmpenv {
  32     struct jmpenv *     je_prev;
  33     Sigjmp_buf          je_buf;         /* only for use if !je_throw */
  34     int                 je_ret;         /* last exception thrown */
  35     bool                je_mustcatch;   /* need to call longjmp()? */
  36 };
  37
  38 typedef struct jmpenv JMPENV;
  39
  40 #ifdef OP_IN_REGISTER
  41 #define OP_REG_TO_MEM   PL_opsave = op
  42 #define OP_MEM_TO_REG   op = PL_opsave
  43 #else
  44 #define OP_REG_TO_MEM   NOOP
  45 #define OP_MEM_TO_REG   NOOP
  46 #endif
  47
  48 /*
  49  * How to build the first jmpenv.
  50  *
  51  * top_env needs to be non-zero. It points to an area
  52  * in which longjmp() stuff is stored, as C callstack
  53  * info there at least is thread specific this has to
  54  * be per-thread. Otherwise a 'die' in a thread gives
  55  * that thread the C stack of last thread to do an eval {}!
  56  */
  57
  58 #define JMPENV_BOOTSTRAP \
  59     STMT_START {                                \
  60         Zero(&PL_start_env, 1, JMPENV);         \
  61         PL_start_env.je_ret = -1;               \
  62         PL_start_env.je_mustcatch = TRUE;       \
  63         PL_top_env = &PL_start_env;             \
  64     } STMT_END
  65
  66 /*
  67  *   PERL_FLEXIBLE_EXCEPTIONS
  68  *
  69  * All the flexible exceptions code has been removed.
  70  * See the following threads for details:
  71  *
  72  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2004-07/msg00378.html
  73  *
  74  * Joshua's original patches (which weren't applied) and discussion:
  75  *
  76  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01396.html
  77  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01489.html
  78  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01491.html
  79  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01608.html
  80  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02144.html
  81  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02998.html
  82  *
  83  * Chip's reworked patch and discussion:
  84  *
  85  *   http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1999-03/msg00520.html
  86  *
  87  * The flaw in these patches (which went unnoticed at the time) was
  88  * that they moved some code that could potentially die() out of the
  89  * region protected by the setjmp()s.  This caused exceptions within
  90  * END blocks and such to not be handled by the correct setjmp().
  91  *
  92  * The original patches that introduces flexible exceptions were:
  93  *
  94  *   http://public.activestate.com/cgi-bin/perlbrowse?patch=3386
  95  *   http://public.activestate.com/cgi-bin/perlbrowse?patch=5162
  96  */
  97
  98 #define dJMPENV         JMPENV cur_env
  99
 100 #define JMPENV_PUSH(v) \
 101     STMT_START {                                                        \
 102         DEBUG_l(Perl_deb(aTHX_ "Setting up jumplevel %p, was %p\n",     \
 103                          (void*)&cur_env, (void*)PL_top_env));                  \
 104         cur_env.je_prev = PL_top_env;                                   \
 105         OP_REG_TO_MEM;                                                  \
 106         cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, SCOPE_SAVES_SIGNAL_MASK);              \
 107         OP_MEM_TO_REG;                                                  \
 108         PL_top_env = &cur_env;                                          \
 109         cur_env.je_mustcatch = FALSE;                                   \
 110         (v) = cur_env.je_ret;                                           \
 111     } STMT_END
 112
 113 #define JMPENV_POP \
 114     STMT_START {                                                        \
 115         DEBUG_l(Perl_deb(aTHX_ "popping jumplevel was %p, now %p\n",    \
 116                          (void*)PL_top_env, (void*)cur_env.je_prev));                   \
 117         PL_top_env = cur_env.je_prev;                                   \
 118     } STMT_END
 119
 120 #define JMPENV_JUMP(v) \
 121     STMT_START {                                                \
 122         OP_REG_TO_MEM;                                          \
 123         if (PL_top_env->je_prev)                                \
 124             PerlProc_longjmp(PL_top_env->je_buf, (v));          \
 125         if ((v) == 2)                                           \
 126             PerlProc_exit(STATUS_EXIT);                         \
 127         PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");     \
 128         PerlProc_exit(1);                                       \
 129     } STMT_END
 130
 131 #define CATCH_GET               (PL_top_env->je_mustcatch)
 132 #define CATCH_SET(v)            (PL_top_env->je_mustcatch = (v))
 133
 134
 135
 136 struct cop {
 137     BASEOP
 138     char *      cop_label;      /* label for this construct */
 139 #ifdef USE_ITHREADS
 140     char *      cop_stashpv;    /* package line was compiled in */
 141     char *      cop_file;       /* file name the following line # is from */
 142 #else
 143     HV *        cop_stash;      /* package line was compiled in */
 144     GV *        cop_filegv;     /* file the following line # is from */
 145 #endif
 146     U32         cop_hints;      /* hints bits from pragmata */
 147     U32         cop_seq;        /* parse sequence number */
 148     line_t      cop_line;       /* line # of this command */
 149     /* Beware. mg.c and warnings.pl assume the type of this is STRLEN *:  */
 150     STRLEN *    cop_warnings;   /* lexical warnings bitmask */
 151     /* compile time state of %^H.  See the comment in op.c for how this is
 152        used to recreate a hash to return from caller.  */
 153     struct refcounted_he * cop_hints_hash;
 154 };
 155
 156 #ifdef USE_ITHREADS
 157 #  define CopFILE(c)            ((c)->cop_file)
 158 #  define CopFILEGV(c)          (CopFILE(c) \
 159                                  ? gv_fetchfile(CopFILE(c)) : NULL)
 160
 161 #  ifdef NETWARE
 162 #    define CopFILE_set(c,pv)   ((c)->cop_file = savepv(pv))
 163 #  else
 164 #    define CopFILE_set(c,pv)   ((c)->cop_file = savesharedpv(pv))
 165 #  endif
 166
 167 #  define CopFILESV(c)          (CopFILE(c) \
 168                                  ? GvSV(gv_fetchfile(CopFILE(c))) : NULL)
 169 #  define CopFILEAV(c)          (CopFILE(c) \
 170                                  ? GvAV(gv_fetchfile(CopFILE(c))) : NULL)
 171 #  ifdef DEBUGGING
 172 #    define CopFILEAVx(c)       (assert(CopFILE(c)), \
 173                                    GvAV(gv_fetchfile(CopFILE(c))))
 174 #  else
 175 #    define CopFILEAVx(c)       (GvAV(gv_fetchfile(CopFILE(c))))
 176 #  endif
 177 #  define CopSTASHPV(c)         ((c)->cop_stashpv)
 178
 179 #  ifdef NETWARE
 180 #    define CopSTASHPV_set(c,pv)        ((c)->cop_stashpv = ((pv) ? savepv(pv) : NULL))
 181 #  else
 182 #    define CopSTASHPV_set(c,pv)        ((c)->cop_stashpv = savesharedpv(pv))
 183 #  endif
 184
 185 #  define CopSTASH(c)           (CopSTASHPV(c) \
 186                                  ? gv_stashpv(CopSTASHPV(c),GV_ADD) : NULL)
 187 #  define CopSTASH_set(c,hv)    CopSTASHPV_set(c, (hv) ? HvNAME_get(hv) : NULL)
 188 #  define CopSTASH_eq(c,hv)     ((hv) && stashpv_hvname_match(c,hv))
 189 #  ifdef NETWARE
 190 #    define CopSTASH_free(c) SAVECOPSTASH_FREE(c)
 191 #    define CopFILE_free(c) SAVECOPFILE_FREE(c)
 192 #  else
 193 #    define CopSTASH_free(c)    PerlMemShared_free(CopSTASHPV(c))
 194 #    define CopFILE_free(c)     (PerlMemShared_free(CopFILE(c)),(CopFILE(c) = NULL))
 195 #  endif
 196 #else
 197 #  define CopFILEGV(c)          ((c)->cop_filegv)
 198 #  define CopFILEGV_set(c,gv)   ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
 199 #  define CopFILE_set(c,pv)     CopFILEGV_set((c), gv_fetchfile(pv))
 200 #  define CopFILESV(c)          (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : NULL)
 201 #  define CopFILEAV(c)          (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : NULL)
 202 #  ifdef DEBUGGING
 203 #    define CopFILEAVx(c)       (assert(CopFILEGV(c)), GvAV(CopFILEGV(c)))
 204 #  else
 205 #    define CopFILEAVx(c)       (GvAV(CopFILEGV(c)))
 206 # endif
 207 #  define CopFILE(c)            (CopFILESV(c) ? SvPVX(CopFILESV(c)) : NULL)
 208 #  define CopSTASH(c)           ((c)->cop_stash)
 209 #  define CopSTASH_set(c,hv)    ((c)->cop_stash = (hv))
 210 #  define CopSTASHPV(c)         (CopSTASH(c) ? HvNAME_get(CopSTASH(c)) : NULL)
 211    /* cop_stash is not refcounted */
 212 #  define CopSTASHPV_set(c,pv)  CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
 213 #  define CopSTASH_eq(c,hv)     (CopSTASH(c) == (hv))
 214 #  define CopSTASH_free(c)
 215 #  define CopFILE_free(c)       (SvREFCNT_dec(CopFILEGV(c)),(CopFILEGV(c) = NULL))
 216
 217 #endif /* USE_ITHREADS */
 218
 219 #define CopSTASH_ne(c,hv)       (!CopSTASH_eq(c,hv))
 220 #define CopLINE(c)              ((c)->cop_line)
 221 #define CopLINE_inc(c)          (++CopLINE(c))
 222 #define CopLINE_dec(c)          (--CopLINE(c))
 223 #define CopLINE_set(c,l)        (CopLINE(c) = (l))
 224
 225 /* OutCopFILE() is CopFILE for output (caller, die, warn, etc.) */
 226 #ifdef MACOS_TRADITIONAL
 227 #  define OutCopFILE(c) MacPerl_MPWFileName(CopFILE(c))
 228 #else
 229 #  define OutCopFILE(c) CopFILE(c)
 230 #endif
 231
 232 /* If $[ is non-zero, it's stored in cop_hints under the key "$[", and
 233    HINT_ARYBASE is set to indicate this.
 234    Setting it is ineficient due to the need to create 2 mortal SVs, but as
 235    using $[ is highly discouraged, no sane Perl code will be using it.  */
 236 #define CopARYBASE_get(c)       \
 237         ((CopHINTS_get(c) & HINT_ARYBASE)                               \
 238          ? SvIV(Perl_refcounted_he_fetch(aTHX_ (c)->cop_hints_hash, 0,  \
 239                                          "$[", 2, 0, 0))                \
 240          : 0)
 241 #define CopARYBASE_set(c, b) STMT_START { \
 242         if (b || ((c)->cop_hints & HINT_ARYBASE)) {                     \
 243             (c)->cop_hints |= HINT_ARYBASE;                             \
 244             if ((c) == &PL_compiling)                                   \
 245                 PL_hints |= HINT_LOCALIZE_HH | HINT_ARYBASE;            \
 246             (c)->cop_hints_hash                                         \
 247                = Perl_refcounted_he_new(aTHX_ (c)->cop_hints_hash,      \
 248                                         sv_2mortal(newSVpvs("$[")),     \
 249                                         sv_2mortal(newSViv(b)));        \
 250         }                                                               \
 251     } STMT_END
 252
 253 /* FIXME NATIVE_HINTS if this is changed from op_private (see perl.h)  */
 254 #define CopHINTS_get(c)         ((c)->cop_hints + 0)
 255 #define CopHINTS_set(c, h)      STMT_START {                            \
 256                                     (c)->cop_hints = (h);               \
 257                                 } STMT_END
 258
 259 /*
 260  * Here we have some enormously heavy (or at least ponderous) wizardry.
 261  */
 262
 263 /* subroutine context */
 264 struct block_sub {
 265     CV *        cv;
 266     GV *        gv;
 267     GV *        dfoutgv;
 268     AV *        savearray;
 269     AV *        argarray;
 270     I32         olddepth;
 271     U8          hasargs;
 272     U8          lval;           /* XXX merge lval and hasargs? */
 273     PAD         *oldcomppad;
 274     OP *        retop;  /* op to execute on exit from sub */
 275 };
 276
 277 /* base for the next two macros. Don't use directly.
 278  * Note that the refcnt of the cv is incremented twice;  The CX one is
 279  * decremented by LEAVESUB, the other by LEAVE. */
 280
 281 #define PUSHSUB_BASE(cx)                                                \
 282         cx->blk_sub.cv = cv;                                            \
 283         cx->blk_sub.olddepth = CvDEPTH(cv);                             \
 284         cx->blk_sub.hasargs = hasargs;                                  \
 285         cx->blk_sub.retop = NULL;                                       \
 286         if (!CvDEPTH(cv)) {                                             \
 287             SvREFCNT_inc_simple_void_NN(cv);                            \
 288             SvREFCNT_inc_simple_void_NN(cv);                            \
 289             SAVEFREESV(cv);                                             \
 290         }
 291
 292
 293 #define PUSHSUB(cx)                                                     \
 294         PUSHSUB_BASE(cx)                                                \
 295         cx->blk_sub.lval = PL_op->op_private &                          \
 296                               (OPpLVAL_INTRO|OPpENTERSUB_INARGS);
 297
 298 /* variant for use by OP_DBSTATE, where op_private holds hint bits */
 299 #define PUSHSUB_DB(cx)                                                  \
 300         PUSHSUB_BASE(cx)                                                \
 301         cx->blk_sub.lval = 0;
 302
 303
 304 #define PUSHFORMAT(cx)                                                  \
 305         cx->blk_sub.cv = cv;                                            \
 306         cx->blk_sub.gv = gv;                                            \
 307         cx->blk_sub.retop = NULL;                                       \
 308         cx->blk_sub.hasargs = 0;                                        \
 309         cx->blk_sub.dfoutgv = PL_defoutgv;                              \
 310         SvREFCNT_inc_void(cx->blk_sub.dfoutgv)
 311
 312 #define POP_SAVEARRAY()                                         \
 313     STMT_START {                                                        \
 314         SvREFCNT_dec(GvAV(PL_defgv));                                   \
 315         GvAV(PL_defgv) = cx->blk_sub.savearray;                         \
 316     } STMT_END
 317
 318 /* junk in @_ spells trouble when cloning CVs and in pp_caller(), so don't
 319  * leave any (a fast av_clear(ary), basically) */
 320 #define CLEAR_ARGARRAY(ary) \
 321     STMT_START {                                                        \
 322         AvMAX(ary) += AvARRAY(ary) - AvALLOC(ary);                      \
 323         AvARRAY(ary) = AvALLOC(ary);                                    \
 324         AvFILLp(ary) = -1;                                              \
 325     } STMT_END
 326
 327 #define POPSUB(cx,sv)                                                   \
 328     STMT_START {                                                        \
 329         if (cx->blk_sub.hasargs) {                                      \
 330             POP_SAVEARRAY();                                            \
 331             /* abandon @_ if it got reified */                          \
 332             if (AvREAL(cx->blk_sub.argarray)) {                         \
 333                 const SSize_t fill = AvFILLp(cx->blk_sub.argarray);     \
 334                 SvREFCNT_dec(cx->blk_sub.argarray);                     \
 335                 cx->blk_sub.argarray = newAV();                         \
 336                 av_extend(cx->blk_sub.argarray, fill);                  \
 337                 AvREIFY_only(cx->blk_sub.argarray);                     \
 338                 CX_CURPAD_SV(cx->blk_sub, 0) = (SV*)cx->blk_sub.argarray;       \
 339             }                                                           \
 340             else {                                                      \
 341                 CLEAR_ARGARRAY(cx->blk_sub.argarray);                   \
 342             }                                                           \
 343         }                                                               \
 344         sv = (SV*)cx->blk_sub.cv;                                       \
 345         if (sv && (CvDEPTH((CV*)sv) = cx->blk_sub.olddepth))            \
 346             sv = NULL;                                          \
 347     } STMT_END
 348
 349 #define LEAVESUB(sv)                                                    \
 350     STMT_START {                                                        \
 351         if (sv)                                                         \
 352             SvREFCNT_dec(sv);                                           \
 353     } STMT_END
 354
 355 #define POPFORMAT(cx)                                                   \
 356         setdefout(cx->blk_sub.dfoutgv);                                 \
 357         SvREFCNT_dec(cx->blk_sub.dfoutgv);
 358
 359 /* eval context */
 360 struct block_eval {
 361     U8          old_in_eval;
 362     U16         old_op_type;
 363     SV *        old_namesv;
 364     OP *        old_eval_root;
 365     SV *        cur_text;
 366     CV *        cv;
 367     OP *        retop;  /* op to execute on exit from eval */
 368     JMPENV *    cur_top_env; /* value of PL_top_env when eval CX created */
 369 };
 370
 371 #define PUSHEVAL(cx,n,fgv)                                              \
 372     STMT_START {                                                        \
 373         cx->blk_eval.old_in_eval = PL_in_eval;                          \
 374         cx->blk_eval.old_op_type = PL_op->op_type;                      \
 375         cx->blk_eval.old_namesv = (n ? newSVpv(n,0) : NULL);            \
 376         cx->blk_eval.old_eval_root = PL_eval_root;                      \
 377         cx->blk_eval.cur_text = PL_linestr;                             \
 378         cx->blk_eval.cv = NULL; /* set by doeval(), as applicable */    \
 379         cx->blk_eval.retop = NULL;                                      \
 380         cx->blk_eval.cur_top_env = PL_top_env;                          \
 381     } STMT_END
 382
 383 #define POPEVAL(cx)                                                     \
 384     STMT_START {                                                        \
 385         PL_in_eval = cx->blk_eval.old_in_eval;                          \
 386         optype = cx->blk_eval.old_op_type;                              \
 387         PL_eval_root = cx->blk_eval.old_eval_root;                      \
 388         if (cx->blk_eval.old_namesv)                                    \
 389             sv_2mortal(cx->blk_eval.old_namesv);                        \
 390     } STMT_END
 391
 392 /* loop context */
 393 struct block_loop {
 394     char *      label;
 395     I32         resetsp;
 396     LOOP *      my_op;  /* My op, that contains redo, next and last ops.  */
 397     /* (except for non_ithreads we need to modify next_op in pp_ctl.c, hence
 398         why next_op is conditionally defined below.)  */
 399 #ifdef USE_ITHREADS
 400     void *      iterdata;
 401     PAD         *oldcomppad;
 402 #else
 403     OP *        next_op;
 404     SV **       itervar;
 405 #endif
 406     SV *        itersave;
 407     /* (from inspection of source code) for a .. range of strings this is the
 408        current string.  */
 409     SV *        iterlval;
 410     /* (from inspection of source code) for a foreach loop this is the array
 411        being iterated over. For a .. range of numbers it's the current value.
 412        A check is often made on the SvTYPE of iterary to determine whether
 413        we are iterating over an array or a range. (numbers or strings)  */
 414     AV *        iterary;
 415     IV          iterix;
 416     /* (from inspection of source code) for a .. range of numbers this is the
 417        maximum value.  */
 418     IV          itermax;
 419 };
 420 /* It might be possible to squeeze this structure further. As best I can tell
 421    itermax and iterlval are never used at the same time, so it might be possible
 422    to make them into a union. However, I'm not confident that there are enough
 423    flag bits/NULLable pointers in this structure alone to encode which is
 424    active. There is, however, U8 of space free in struct block, which could be
 425    used. Right now it may not be worth squeezing this structure further, as it's
 426    the largest part of struct block, and currently struct block is 64 bytes on
 427    an ILP32 system, which will give good cache alignment.
 428 */
 429
 430 #ifdef USE_ITHREADS
 431 #  define CxITERVAR(c)                                                  \
 432         ((c)->blk_loop.iterdata                                         \
 433          ? (CxPADLOOP(cx)                                               \
 434             ? &CX_CURPAD_SV( (c)->blk_loop,                             \
 435                     INT2PTR(PADOFFSET, (c)->blk_loop.iterdata))         \
 436             : &GvSV((GV*)(c)->blk_loop.iterdata))                       \
 437          : (SV**)NULL)
 438 #  define CX_ITERDATA_SET(cx,idata)                                     \
 439         CX_CURPAD_SAVE(cx->blk_loop);                                   \
 440         if ((cx->blk_loop.iterdata = (idata)))                          \
 441             cx->blk_loop.itersave = SvREFCNT_inc(*CxITERVAR(cx));       \
 442         else                                                            \
 443             cx->blk_loop.itersave = NULL;
 444 #else
 445 #  define CxITERVAR(c)          ((c)->blk_loop.itervar)
 446 #  define CX_ITERDATA_SET(cx,ivar)                                      \
 447         if ((cx->blk_loop.itervar = (SV**)(ivar)))                      \
 448             cx->blk_loop.itersave = SvREFCNT_inc(*CxITERVAR(cx));       \
 449         else                                                            \
 450             cx->blk_loop.itersave = NULL;
 451 #endif
 452
 453 #ifdef USE_ITHREADS
 454 #  define PUSHLOOP_OP_NEXT              /* No need to do anything.  */
 455 #  define CX_LOOP_NEXTOP_GET(cx)        ((cx)->blk_loop.my_op->op_nextop + 0)
 456 #else
 457 #  define PUSHLOOP_OP_NEXT              cx->blk_loop.next_op = cLOOP->op_nextop
 458 #  define CX_LOOP_NEXTOP_GET(cx)        ((cx)->blk_loop.next_op + 0)
 459 #endif
 460
 461 #define PUSHLOOP(cx, dat, s)                                            \
 462         cx->blk_loop.label = PL_curcop->cop_label;                      \
 463         cx->blk_loop.resetsp = s - PL_stack_base;                       \
 464         cx->blk_loop.my_op = cLOOP;                                     \
 465         PUSHLOOP_OP_NEXT;                                               \
 466         cx->blk_loop.iterlval = NULL;                                   \
 467         cx->blk_loop.iterary = NULL;                                    \
 468         cx->blk_loop.iterix = -1;                                       \
 469         CX_ITERDATA_SET(cx,dat);
 470
 471 #define POPLOOP(cx)                                                     \
 472         SvREFCNT_dec(cx->blk_loop.iterlval);                            \
 473         if (CxITERVAR(cx)) {                                            \
 474             if (SvPADMY(cx->blk_loop.itersave)) {                       \
 475                 SV ** const s_v_p = CxITERVAR(cx);                      \
 476                 sv_2mortal(*s_v_p);                                     \
 477                 *s_v_p = cx->blk_loop.itersave;                         \
 478             }                                                           \
 479             else {                                                      \
 480                 SvREFCNT_dec(cx->blk_loop.itersave);                    \
 481             }                                                           \
 482         }                                                               \
 483         if (cx->blk_loop.iterary && cx->blk_loop.iterary != PL_curstack)\
 484             SvREFCNT_dec(cx->blk_loop.iterary);
 485
 486 /* given/when context */
 487 struct block_givwhen {
 488         OP *leave_op;
 489 };
 490
 491 #define PUSHGIVEN(cx)                                                   \
 492         cx->blk_givwhen.leave_op = cLOGOP->op_other;
 493
 494 #define PUSHWHEN PUSHGIVEN
 495
 496 /* context common to subroutines, evals and loops */
 497 struct block {
 498     U16         blku_type;      /* what kind of context this is */
 499     U8          blku_gimme;     /* is this block running in list context? */
 500     U8          blku_spare;     /* Padding to match with struct subst */
 501     I32         blku_oldsp;     /* stack pointer to copy stuff down to */
 502     COP *       blku_oldcop;    /* old curcop pointer */
 503     I32         blku_oldmarksp; /* mark stack index */
 504     I32         blku_oldscopesp;        /* scope stack index */
 505     PMOP *      blku_oldpm;     /* values of pattern match vars */
 506
 507     union {
 508         struct block_sub        blku_sub;
 509         struct block_eval       blku_eval;
 510         struct block_loop       blku_loop;
 511         struct block_givwhen    blku_givwhen;
 512     } blk_u;
 513 };
 514 #define blk_oldsp       cx_u.cx_blk.blku_oldsp
 515 #define blk_oldcop      cx_u.cx_blk.blku_oldcop
 516 #define blk_oldmarksp   cx_u.cx_blk.blku_oldmarksp
 517 #define blk_oldscopesp  cx_u.cx_blk.blku_oldscopesp
 518 #define blk_oldpm       cx_u.cx_blk.blku_oldpm
 519 #define blk_gimme       cx_u.cx_blk.blku_gimme
 520 #define blk_sub         cx_u.cx_blk.blk_u.blku_sub
 521 #define blk_eval        cx_u.cx_blk.blk_u.blku_eval
 522 #define blk_loop        cx_u.cx_blk.blk_u.blku_loop
 523 #define blk_givwhen     cx_u.cx_blk.blk_u.blku_givwhen
 524
 525 /* Enter a block. */
 526 #define PUSHBLOCK(cx,t,sp) CXINC, cx = &cxstack[cxstack_ix],            \
 527         cx->cx_type             = t,                                    \
 528         cx->blk_oldsp           = sp - PL_stack_base,                   \
 529         cx->blk_oldcop          = PL_curcop,                            \
 530         cx->blk_oldmarksp       = PL_markstack_ptr - PL_markstack,      \
 531         cx->blk_oldscopesp      = PL_scopestack_ix,                     \
 532         cx->blk_oldpm           = PL_curpm,                             \
 533         cx->blk_gimme           = (U8)gimme;                            \
 534         DEBUG_l( PerlIO_printf(Perl_debug_log, "Entering block %ld, type %s\n", \
 535                     (long)cxstack_ix, PL_block_type[CxTYPE(cx)]); )
 536
 537 /* Exit a block (RETURN and LAST). */
 538 #define POPBLOCK(cx,pm) cx = &cxstack[cxstack_ix--],                    \
 539         newsp            = PL_stack_base + cx->blk_oldsp,               \
 540         PL_curcop        = cx->blk_oldcop,                              \
 541         PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp,            \
 542         PL_scopestack_ix = cx->blk_oldscopesp,                          \
 543         pm               = cx->blk_oldpm,                               \
 544         gimme            = cx->blk_gimme;                               \
 545         DEBUG_SCOPE("POPBLOCK");                                        \
 546         DEBUG_l( PerlIO_printf(Perl_debug_log, "Leaving block %ld, type %s\n",          \
 547                     (long)cxstack_ix+1,PL_block_type[CxTYPE(cx)]); )
 548
 549 /* Continue a block elsewhere (NEXT and REDO). */
 550 #define TOPBLOCK(cx) cx  = &cxstack[cxstack_ix],                        \
 551         PL_stack_sp      = PL_stack_base + cx->blk_oldsp,               \
 552         PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp,            \
 553         PL_scopestack_ix = cx->blk_oldscopesp,                          \
 554         PL_curpm         = cx->blk_oldpm;                               \
 555         DEBUG_SCOPE("TOPBLOCK");
 556
 557 /* substitution context */
 558 struct subst {
 559     U16         sbu_type;       /* what kind of context this is */
 560     U8          sbu_once;       /* Actually both booleans, but U8 to matches */
 561     U8          sbu_rxtainted;  /* struct block */
 562     I32         sbu_iters;
 563     I32         sbu_maxiters;
 564     I32         sbu_rflags;
 565     I32         sbu_oldsave;
 566     char *      sbu_orig;
 567     SV *        sbu_dstr;
 568     SV *        sbu_targ;
 569     char *      sbu_s;
 570     char *      sbu_m;
 571     char *      sbu_strend;
 572     void *      sbu_rxres;
 573     REGEXP *    sbu_rx;
 574 };
 575 #define sb_iters        cx_u.cx_subst.sbu_iters
 576 #define sb_maxiters     cx_u.cx_subst.sbu_maxiters
 577 #define sb_rflags       cx_u.cx_subst.sbu_rflags
 578 #define sb_oldsave      cx_u.cx_subst.sbu_oldsave
 579 #define sb_once         cx_u.cx_subst.sbu_once
 580 #define sb_rxtainted    cx_u.cx_subst.sbu_rxtainted
 581 #define sb_orig         cx_u.cx_subst.sbu_orig
 582 #define sb_dstr         cx_u.cx_subst.sbu_dstr
 583 #define sb_targ         cx_u.cx_subst.sbu_targ
 584 #define sb_s            cx_u.cx_subst.sbu_s
 585 #define sb_m            cx_u.cx_subst.sbu_m
 586 #define sb_strend       cx_u.cx_subst.sbu_strend
 587 #define sb_rxres        cx_u.cx_subst.sbu_rxres
 588 #define sb_rx           cx_u.cx_subst.sbu_rx
 589
 590 #define PUSHSUBST(cx) CXINC, cx = &cxstack[cxstack_ix],                 \
 591         cx->sb_iters            = iters,                                \
 592         cx->sb_maxiters         = maxiters,                             \
 593         cx->sb_rflags           = r_flags,                              \
 594         cx->sb_oldsave          = oldsave,                              \
 595         cx->sb_once             = once,                                 \
 596         cx->sb_rxtainted        = rxtainted,                            \
 597         cx->sb_orig             = orig,                                 \
 598         cx->sb_dstr             = dstr,                                 \
 599         cx->sb_targ             = targ,                                 \
 600         cx->sb_s                = s,                                    \
 601         cx->sb_m                = m,                                    \
 602         cx->sb_strend           = strend,                               \
 603         cx->sb_rxres            = NULL,                                 \
 604         cx->sb_rx               = rx,                                   \
 605         cx->cx_type             = CXt_SUBST;                            \
 606         rxres_save(&cx->sb_rxres, rx);                                  \
 607         (void)ReREFCNT_inc(rx)
 608
 609 #define POPSUBST(cx) cx = &cxstack[cxstack_ix--];                       \
 610         rxres_free(&cx->sb_rxres);                                      \
 611         ReREFCNT_dec(cx->sb_rx)
 612
 613 struct context {
 614     union {
 615         struct block    cx_blk;
 616         struct subst    cx_subst;
 617     } cx_u;
 618 };
 619 #define cx_type cx_u.cx_subst.sbu_type
 620
 621 #define CXTYPEMASK      0xff
 622 #define CXt_NULL        0
 623 #define CXt_SUB         1
 624 #define CXt_EVAL        2
 625 #define CXt_LOOP        3
 626 #define CXt_SUBST       4
 627 #define CXt_BLOCK       5
 628 #define CXt_FORMAT      6
 629 #define CXt_GIVEN       7
 630 #define CXt_WHEN        8
 631
 632 /* private flags for CXt_SUB and CXt_NULL */
 633 #define CXp_MULTICALL   0x00000400      /* part of a multicall (so don't
 634                                            tear down context on exit). */
 635
 636 /* private flags for CXt_EVAL */
 637 #define CXp_REAL        0x00000100      /* truly eval'', not a lookalike */
 638 #define CXp_TRYBLOCK    0x00000200      /* eval{}, not eval'' or similar */
 639
 640 /* private flags for CXt_LOOP */
 641 #define CXp_FOREACH     0x00000200      /* a foreach loop */
 642 #define CXp_FOR_DEF     0x00000400      /* foreach using $_ */
 643 #ifdef USE_ITHREADS
 644 #  define CXp_PADVAR    0x00000100      /* itervar lives on pad, iterdata
 645                                            has pad offset; if not set,
 646                                            iterdata holds GV* */
 647 #  define CxPADLOOP(c)  (((c)->cx_type & (CXt_LOOP|CXp_PADVAR))         \
 648                          == (CXt_LOOP|CXp_PADVAR))
 649 #endif
 650
 651 #define CxTYPE(c)       ((c)->cx_type & CXTYPEMASK)
 652 #define CxMULTICALL(c)  (((c)->cx_type & CXp_MULTICALL)                 \
 653                          == CXp_MULTICALL)
 654 #define CxREALEVAL(c)   (((c)->cx_type & (CXt_EVAL|CXp_REAL))           \
 655                          == (CXt_EVAL|CXp_REAL))
 656 #define CxTRYBLOCK(c)   (((c)->cx_type & (CXt_EVAL|CXp_TRYBLOCK))       \
 657                          == (CXt_EVAL|CXp_TRYBLOCK))
 658 #define CxFOREACH(c)    (((c)->cx_type & (CXt_LOOP|CXp_FOREACH))        \
 659                          == (CXt_LOOP|CXp_FOREACH))
 660 #define CxFOREACHDEF(c) (((c)->cx_type & (CXt_LOOP|CXp_FOREACH|CXp_FOR_DEF))\
 661                          == (CXt_LOOP|CXp_FOREACH|CXp_FOR_DEF))
 662
 663 #define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc()))
 664
 665 /*
 666 =head1 "Gimme" Values
 667 */
 668
 669 /*
 670 =for apidoc AmU||G_SCALAR
 671 Used to indicate scalar context.  See C<GIMME_V>, C<GIMME>, and
 672 L<perlcall>.
 673
 674 =for apidoc AmU||G_ARRAY
 675 Used to indicate list context.  See C<GIMME_V>, C<GIMME> and
 676 L<perlcall>.
 677
 678 =for apidoc AmU||G_VOID
 679 Used to indicate void context.  See C<GIMME_V> and L<perlcall>.
 680
 681 =for apidoc AmU||G_DISCARD
 682 Indicates that arguments returned from a callback should be discarded.  See
 683 L<perlcall>.
 684
 685 =for apidoc AmU||G_EVAL
 686
 687 Used to force a Perl C<eval> wrapper around a callback.  See
 688 L<perlcall>.
 689
 690 =for apidoc AmU||G_NOARGS
 691
 692 Indicates that no arguments are being sent to a callback.  See
 693 L<perlcall>.
 694
 695 =cut
 696 */
 697
 698 #define G_SCALAR        0
 699 #define G_ARRAY         1
 700 #define G_VOID          128     /* skip this bit when adding flags below */
 701
 702 /* extra flags for Perl_call_* routines */
 703 #define G_DISCARD       2       /* Call FREETMPS. */
 704 #define G_EVAL          4       /* Assume eval {} around subroutine call. */
 705 #define G_NOARGS        8       /* Don't construct a @_ array. */
 706 #define G_KEEPERR      16       /* Append errors to $@, don't overwrite it */
 707 #define G_NODEBUG      32       /* Disable debugging at toplevel.  */
 708 #define G_METHOD       64       /* Calling method. */
 709 #define G_FAKINGEVAL  256       /* Faking en eval context for call_sv or
 710                                    fold_constants. */
 711
 712 /* flag bits for PL_in_eval */
 713 #define EVAL_NULL       0       /* not in an eval */
 714 #define EVAL_INEVAL     1       /* some enclosing scope is an eval */
 715 #define EVAL_WARNONLY   2       /* used by yywarn() when calling yyerror() */
 716 #define EVAL_KEEPERR    4       /* set by Perl_call_sv if G_KEEPERR */
 717 #define EVAL_INREQUIRE  8       /* The code is being required. */
 718
 719 /* Support for switching (stack and block) contexts.
 720  * This ensures magic doesn't invalidate local stack and cx pointers.
 721  */
 722
 723 #define PERLSI_UNKNOWN          -1
 724 #define PERLSI_UNDEF            0
 725 #define PERLSI_MAIN             1
 726 #define PERLSI_MAGIC            2
 727 #define PERLSI_SORT             3
 728 #define PERLSI_SIGNAL           4
 729 #define PERLSI_OVERLOAD         5
 730 #define PERLSI_DESTROY          6
 731 #define PERLSI_WARNHOOK         7
 732 #define PERLSI_DIEHOOK          8
 733 #define PERLSI_REQUIRE          9
 734
 735 struct stackinfo {
 736     AV *                si_stack;       /* stack for current runlevel */
 737     PERL_CONTEXT *      si_cxstack;     /* context stack for runlevel */
 738     I32                 si_cxix;        /* current context index */
 739     I32                 si_cxmax;       /* maximum allocated index */
 740     I32                 si_type;        /* type of runlevel */
 741     struct stackinfo *  si_prev;
 742     struct stackinfo *  si_next;
 743     I32                 si_markoff;     /* offset where markstack begins for us.
 744                                          * currently used only with DEBUGGING,
 745                                          * but not #ifdef-ed for bincompat */
 746 };
 747
 748 typedef struct stackinfo PERL_SI;
 749
 750 #define cxstack         (PL_curstackinfo->si_cxstack)
 751 #define cxstack_ix      (PL_curstackinfo->si_cxix)
 752 #define cxstack_max     (PL_curstackinfo->si_cxmax)
 753
 754 #ifdef DEBUGGING
 755 #  define       SET_MARK_OFFSET \
 756     PL_curstackinfo->si_markoff = PL_markstack_ptr - PL_markstack
 757 #else
 758 #  define       SET_MARK_OFFSET NOOP
 759 #endif
 760
 761 #define PUSHSTACKi(type) \
 762     STMT_START {                                                        \
 763         PERL_SI *next = PL_curstackinfo->si_next;                       \
 764         if (!next) {                                                    \
 765             next = new_stackinfo(32, 2048/sizeof(PERL_CONTEXT) - 1);    \
 766             next->si_prev = PL_curstackinfo;                            \
 767             PL_curstackinfo->si_next = next;                            \
 768         }                                                               \
 769         next->si_type = type;                                           \
 770         next->si_cxix = -1;                                             \
 771         AvFILLp(next->si_stack) = 0;                                    \
 772         SWITCHSTACK(PL_curstack,next->si_stack);                        \
 773         PL_curstackinfo = next;                                         \
 774         SET_MARK_OFFSET;                                                \
 775     } STMT_END
 776
 777 #define PUSHSTACK PUSHSTACKi(PERLSI_UNKNOWN)
 778
 779 /* POPSTACK works with PL_stack_sp, so it may need to be bracketed by
 780  * PUTBACK/SPAGAIN to flush/refresh any local SP that may be active */
 781 #define POPSTACK \
 782     STMT_START {                                                        \
 783         dSP;                                                            \
 784         PERL_SI * const prev = PL_curstackinfo->si_prev;                \
 785         if (!prev) {                                                    \
 786             PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");         \
 787             my_exit(1);                                                 \
 788         }                                                               \
 789         SWITCHSTACK(PL_curstack,prev->si_stack);                        \
 790         /* don't free prev here, free them all at the END{} */          \
 791         PL_curstackinfo = prev;                                         \
 792     } STMT_END
 793
 794 #define POPSTACK_TO(s) \
 795     STMT_START {                                                        \
 796         while (PL_curstack != s) {                                      \
 797             dounwind(-1);                                               \
 798             POPSTACK;                                                   \
 799         }                                                               \
 800     } STMT_END
 801
 802 #define IN_PERL_COMPILETIME     (PL_curcop == &PL_compiling)
 803 #define IN_PERL_RUNTIME         (PL_curcop != &PL_compiling)
 804
 805 /*
 806 =head1 Multicall Functions
 807
 808 =for apidoc Ams||dMULTICALL
 809 Declare local variables for a multicall. See L<perlcall/Lightweight Callbacks>.
 810
 811 =for apidoc Ams||PUSH_MULTICALL
 812 Opening bracket for a lightweight callback.
 813 See L<perlcall/Lightweight Callbacks>.
 814
 815 =for apidoc Ams||MULTICALL
 816 Make a lightweight callback. See L<perlcall/Lightweight Callbacks>.
 817
 818 =for apidoc Ams||POP_MULTICALL
 819 Closing bracket for a lightweight callback.
 820 See L<perlcall/Lightweight Callbacks>.
 821
 822 =cut
 823 */
 824
 825 #define dMULTICALL \
 826     SV **newsp;                 /* set by POPBLOCK */                   \
 827     PERL_CONTEXT *cx;                                                   \
 828     CV *multicall_cv;                                                   \
 829     OP *multicall_cop;                                                  \
 830     bool multicall_oldcatch;                                            \
 831     U8 hasargs = 0              /* used by PUSHSUB */
 832
 833 #define PUSH_MULTICALL(the_cv) \
 834     STMT_START {                                                        \
 835         CV * const _nOnclAshIngNamE_ = the_cv;                          \
 836         CV * const cv = _nOnclAshIngNamE_;                              \
 837         AV * const padlist = CvPADLIST(cv);                             \
 838         ENTER;                                                          \
 839         multicall_oldcatch = CATCH_GET;                                 \
 840         SAVETMPS; SAVEVPTR(PL_op);                                      \
 841         CATCH_SET(TRUE);                                                \
 842         PUSHBLOCK(cx, CXt_SUB|CXp_MULTICALL, PL_stack_sp);              \
 843         PUSHSUB(cx);                                                    \
 844         if (++CvDEPTH(cv) >= 2) {                                       \
 845             PERL_STACK_OVERFLOW_CHECK();                                \
 846             Perl_pad_push(aTHX_ padlist, CvDEPTH(cv));                  \
 847         }                                                               \
 848         SAVECOMPPAD();                                                  \
 849         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));                       \
 850         multicall_cv = cv;                                              \
 851         multicall_cop = CvSTART(cv);                                    \
 852     } STMT_END
 853
 854 #define MULTICALL \
 855     STMT_START {                                                        \
 856         PL_op = multicall_cop;                                          \
 857         CALLRUNOPS(aTHX);                                               \
 858     } STMT_END
 859
 860 #define POP_MULTICALL \
 861     STMT_START {                                                        \
 862         LEAVESUB(multicall_cv);                                         \
 863         CvDEPTH(multicall_cv)--;                                        \
 864         POPBLOCK(cx,PL_curpm);                                          \
 865         CATCH_SET(multicall_oldcatch);                                  \
 866         LEAVE;                                                          \
 867     } STMT_END
 868
 869 /*
 870  * Local variables:
 871  * c-indentation-style: bsd
 872  * c-basic-offset: 4
 873  * indent-tabs-mode: t
 874  * End:
 875  *
 876  * ex: set ts=8 sts=4 sw=4 noet:
 877  */