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 #  define CopLABEL(c)           ((c)->cop_label)
 190 #  ifdef NETWARE
 191 #    define CopLABEL_set(c,pv)  ((CopLABEL(c) = ((pv) ? savepv(pv) : NULL)), Safefree(pv), ((pv) = NULL))
 192 #  else
 193 #    define CopLABEL_set(c,pv)  ((CopLABEL(c) = savesharedpv(pv)), Safefree(pv), ((pv) = NULL))
 194 #  endif
 195 #  ifdef NETWARE
 196 #    define CopSTASH_free(c) SAVECOPSTASH_FREE(c)
 197 #    define CopFILE_free(c) SAVECOPFILE_FREE(c)
 198 #    define CopLABEL_free(c) SAVECOPLABEL_FREE(c)
 199 #  else
 200 #    define CopSTASH_free(c)    PerlMemShared_free(CopSTASHPV(c))
 201 #    define CopFILE_free(c)     (PerlMemShared_free(CopFILE(c)),(CopFILE(c) = NULL))
 202 #    define CopLABEL_free(c)    (PerlMemShared_free(CopLABEL(c)),(CopLABEL(c) = NULL))
 203 #  endif
 204 #else
 205 #  define CopFILEGV(c)          ((c)->cop_filegv)
 206 #  define CopFILEGV_set(c,gv)   ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
 207 #  define CopFILE_set(c,pv)     CopFILEGV_set((c), gv_fetchfile(pv))
 208 #  define CopFILESV(c)          (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : NULL)
 209 #  define CopFILEAV(c)          (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : NULL)
 210 #  ifdef DEBUGGING
 211 #    define CopFILEAVx(c)       (assert(CopFILEGV(c)), GvAV(CopFILEGV(c)))
 212 #  else
 213 #    define CopFILEAVx(c)       (GvAV(CopFILEGV(c)))
 214 # endif
 215 #  define CopFILE(c)            (CopFILESV(c) ? SvPVX(CopFILESV(c)) : NULL)
 216 #  define CopSTASH(c)           ((c)->cop_stash)
 217 #  define CopLABEL(c)           ((c)->cop_label)
 218 #  define CopSTASH_set(c,hv)    ((c)->cop_stash = (hv))
 219 #  define CopSTASHPV(c)         (CopSTASH(c) ? HvNAME_get(CopSTASH(c)) : NULL)
 220    /* cop_stash is not refcounted */
 221 #  define CopSTASHPV_set(c,pv)  CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
 222 #  define CopSTASH_eq(c,hv)     (CopSTASH(c) == (hv))
 223 #  define CopLABEL_set(c,pv)    (CopLABEL(c) = (pv))
 224 #  define CopSTASH_free(c)
 225 #  define CopFILE_free(c)       (SvREFCNT_dec(CopFILEGV(c)),(CopFILEGV(c) = NULL))
 226 #  define CopLABEL_free(c)
 227
 228 #endif /* USE_ITHREADS */
 229
 230 #define CopSTASH_ne(c,hv)       (!CopSTASH_eq(c,hv))
 231 #define CopLINE(c)              ((c)->cop_line)
 232 #define CopLINE_inc(c)          (++CopLINE(c))
 233 #define CopLINE_dec(c)          (--CopLINE(c))
 234 #define CopLINE_set(c,l)        (CopLINE(c) = (l))
 235
 236 /* OutCopFILE() is CopFILE for output (caller, die, warn, etc.) */
 237 #ifdef MACOS_TRADITIONAL
 238 #  define OutCopFILE(c) MacPerl_MPWFileName(CopFILE(c))
 239 #else
 240 #  define OutCopFILE(c) CopFILE(c)
 241 #endif
 242
 243 /* If $[ is non-zero, it's stored in cop_hints under the key "$[", and
 244    HINT_ARYBASE is set to indicate this.
 245    Setting it is ineficient due to the need to create 2 mortal SVs, but as
 246    using $[ is highly discouraged, no sane Perl code will be using it.  */
 247 #define CopARYBASE_get(c)       \
 248         ((CopHINTS_get(c) & HINT_ARYBASE)                               \
 249          ? SvIV(Perl_refcounted_he_fetch(aTHX_ (c)->cop_hints_hash, 0,  \
 250                                          "$[", 2, 0, 0))                \
 251          : 0)
 252 #define CopARYBASE_set(c, b) STMT_START { \
 253         if (b || ((c)->cop_hints & HINT_ARYBASE)) {                     \
 254             (c)->cop_hints |= HINT_ARYBASE;                             \
 255             if ((c) == &PL_compiling)                                   \
 256                 PL_hints |= HINT_LOCALIZE_HH | HINT_ARYBASE;            \
 257             (c)->cop_hints_hash                                         \
 258                = Perl_refcounted_he_new(aTHX_ (c)->cop_hints_hash,      \
 259                                         sv_2mortal(newSVpvs("$[")),     \
 260                                         sv_2mortal(newSViv(b)));        \
 261         }                                                               \
 262     } STMT_END
 263
 264 /* FIXME NATIVE_HINTS if this is changed from op_private (see perl.h)  */
 265 #define CopHINTS_get(c)         ((c)->cop_hints + 0)
 266 #define CopHINTS_set(c, h)      STMT_START {                            \
 267                                     (c)->cop_hints = (h);               \
 268                                 } STMT_END
 269
 270 /*
 271  * Here we have some enormously heavy (or at least ponderous) wizardry.
 272  */
 273
 274 /* subroutine context */
 275 struct block_sub {
 276     CV *        cv;
 277     GV *        gv;
 278     GV *        dfoutgv;
 279     AV *        savearray;
 280     AV *        argarray;
 281     I32         olddepth;
 282     U8          hasargs;
 283     U8          lval;           /* XXX merge lval and hasargs? */
 284     PAD         *oldcomppad;
 285     OP *        retop;  /* op to execute on exit from sub */
 286 };
 287
 288 /* base for the next two macros. Don't use directly.
 289  * Note that the refcnt of the cv is incremented twice;  The CX one is
 290  * decremented by LEAVESUB, the other by LEAVE. */
 291
 292 #define PUSHSUB_BASE(cx)                                                \
 293         cx->blk_sub.cv = cv;                                            \
 294         cx->blk_sub.olddepth = CvDEPTH(cv);                             \
 295         cx->blk_sub.hasargs = hasargs;                                  \
 296         cx->blk_sub.retop = NULL;                                       \
 297         if (!CvDEPTH(cv)) {                                             \
 298             SvREFCNT_inc_simple_void_NN(cv);                            \
 299             SvREFCNT_inc_simple_void_NN(cv);                            \
 300             SAVEFREESV(cv);                                             \
 301         }
 302
 303
 304 #define PUSHSUB(cx)                                                     \
 305         PUSHSUB_BASE(cx)                                                \
 306         cx->blk_sub.lval = PL_op->op_private &                          \
 307                               (OPpLVAL_INTRO|OPpENTERSUB_INARGS);
 308
 309 /* variant for use by OP_DBSTATE, where op_private holds hint bits */
 310 #define PUSHSUB_DB(cx)                                                  \
 311         PUSHSUB_BASE(cx)                                                \
 312         cx->blk_sub.lval = 0;
 313
 314
 315 #define PUSHFORMAT(cx)                                                  \
 316         cx->blk_sub.cv = cv;                                            \
 317         cx->blk_sub.gv = gv;                                            \
 318         cx->blk_sub.retop = NULL;                                       \
 319         cx->blk_sub.hasargs = 0;                                        \
 320         cx->blk_sub.dfoutgv = PL_defoutgv;                              \
 321         SvREFCNT_inc_void(cx->blk_sub.dfoutgv)
 322
 323 #define POP_SAVEARRAY()                                         \
 324     STMT_START {                                                        \
 325         SvREFCNT_dec(GvAV(PL_defgv));                                   \
 326         GvAV(PL_defgv) = cx->blk_sub.savearray;                         \
 327     } STMT_END
 328
 329 /* junk in @_ spells trouble when cloning CVs and in pp_caller(), so don't
 330  * leave any (a fast av_clear(ary), basically) */
 331 #define CLEAR_ARGARRAY(ary) \
 332     STMT_START {                                                        \
 333         AvMAX(ary) += AvARRAY(ary) - AvALLOC(ary);                      \
 334         AvARRAY(ary) = AvALLOC(ary);                                    \
 335         AvFILLp(ary) = -1;                                              \
 336     } STMT_END
 337
 338 #define POPSUB(cx,sv)                                                   \
 339     STMT_START {                                                        \
 340         if (cx->blk_sub.hasargs) {                                      \
 341             POP_SAVEARRAY();                                            \
 342             /* abandon @_ if it got reified */                          \
 343             if (AvREAL(cx->blk_sub.argarray)) {                         \
 344                 const SSize_t fill = AvFILLp(cx->blk_sub.argarray);     \
 345                 SvREFCNT_dec(cx->blk_sub.argarray);                     \
 346                 cx->blk_sub.argarray = newAV();                         \
 347                 av_extend(cx->blk_sub.argarray, fill);                  \
 348                 AvREIFY_only(cx->blk_sub.argarray);                     \
 349                 CX_CURPAD_SV(cx->blk_sub, 0) = (SV*)cx->blk_sub.argarray;       \
 350             }                                                           \
 351             else {                                                      \
 352                 CLEAR_ARGARRAY(cx->blk_sub.argarray);                   \
 353             }                                                           \
 354         }                                                               \
 355         sv = (SV*)cx->blk_sub.cv;                                       \
 356         if (sv && (CvDEPTH((CV*)sv) = cx->blk_sub.olddepth))            \
 357             sv = NULL;                                          \
 358     } STMT_END
 359
 360 #define LEAVESUB(sv)                                                    \
 361     STMT_START {                                                        \
 362         if (sv)                                                         \
 363             SvREFCNT_dec(sv);                                           \
 364     } STMT_END
 365
 366 #define POPFORMAT(cx)                                                   \
 367         setdefout(cx->blk_sub.dfoutgv);                                 \
 368         SvREFCNT_dec(cx->blk_sub.dfoutgv);
 369
 370 /* eval context */
 371 struct block_eval {
 372     U8          old_in_eval;
 373     U16         old_op_type;
 374     SV *        old_namesv;
 375     OP *        old_eval_root;
 376     SV *        cur_text;
 377     CV *        cv;
 378     OP *        retop;  /* op to execute on exit from eval */
 379     JMPENV *    cur_top_env; /* value of PL_top_env when eval CX created */
 380 };
 381
 382 #define PUSHEVAL(cx,n,fgv)                                              \
 383     STMT_START {                                                        \
 384         cx->blk_eval.old_in_eval = PL_in_eval;                          \
 385         cx->blk_eval.old_op_type = PL_op->op_type;                      \
 386         cx->blk_eval.old_namesv = (n ? newSVpv(n,0) : NULL);            \
 387         cx->blk_eval.old_eval_root = PL_eval_root;                      \
 388         cx->blk_eval.cur_text = PL_linestr;                             \
 389         cx->blk_eval.cv = NULL; /* set by doeval(), as applicable */    \
 390         cx->blk_eval.retop = NULL;                                      \
 391         cx->blk_eval.cur_top_env = PL_top_env;                          \
 392     } STMT_END
 393
 394 #define POPEVAL(cx)                                                     \
 395     STMT_START {                                                        \
 396         PL_in_eval = cx->blk_eval.old_in_eval;                          \
 397         optype = cx->blk_eval.old_op_type;                              \
 398         PL_eval_root = cx->blk_eval.old_eval_root;                      \
 399         if (cx->blk_eval.old_namesv)                                    \
 400             sv_2mortal(cx->blk_eval.old_namesv);                        \
 401     } STMT_END
 402
 403 /* loop context */
 404 struct block_loop {
 405     char *      label;
 406     I32         resetsp;
 407     LOOP *      my_op;  /* My op, that contains redo, next and last ops.  */
 408     /* (except for non_ithreads we need to modify next_op in pp_ctl.c, hence
 409         why next_op is conditionally defined below.)  */
 410 #ifdef USE_ITHREADS
 411     void *      iterdata;
 412     PAD         *oldcomppad;
 413 #else
 414     OP *        next_op;
 415     SV **       itervar;
 416 #endif
 417     SV *        itersave;
 418     /* (from inspection of source code) for a .. range of strings this is the
 419        current string.  */
 420     SV *        iterlval;
 421     /* (from inspection of source code) for a foreach loop this is the array
 422        being iterated over. For a .. range of numbers it's the current value.
 423        A check is often made on the SvTYPE of iterary to determine whether
 424        we are iterating over an array or a range. (numbers or strings)  */
 425     AV *        iterary;
 426     IV          iterix;
 427     /* (from inspection of source code) for a .. range of numbers this is the
 428        maximum value.  */
 429     IV          itermax;
 430 };
 431 /* It might be possible to squeeze this structure further. As best I can tell
 432    itermax and iterlval are never used at the same time, so it might be possible
 433    to make them into a union. However, I'm not confident that there are enough
 434    flag bits/NULLable pointers in this structure alone to encode which is
 435    active. There is, however, U8 of space free in struct block, which could be
 436    used. Right now it may not be worth squeezing this structure further, as it's
 437    the largest part of struct block, and currently struct block is 64 bytes on
 438    an ILP32 system, which will give good cache alignment.
 439 */
 440
 441 #ifdef USE_ITHREADS
 442 #  define CxITERVAR(c)                                                  \
 443         ((c)->blk_loop.iterdata                                         \
 444          ? (CxPADLOOP(cx)                                               \
 445             ? &CX_CURPAD_SV( (c)->blk_loop,                             \
 446                     INT2PTR(PADOFFSET, (c)->blk_loop.iterdata))         \
 447             : &GvSV((GV*)(c)->blk_loop.iterdata))                       \
 448          : (SV**)NULL)
 449 #  define CX_ITERDATA_SET(cx,idata)                                     \
 450         CX_CURPAD_SAVE(cx->blk_loop);                                   \
 451         if ((cx->blk_loop.iterdata = (idata)))                          \
 452             cx->blk_loop.itersave = SvREFCNT_inc(*CxITERVAR(cx));       \
 453         else                                                            \
 454             cx->blk_loop.itersave = NULL;
 455 #else
 456 #  define CxITERVAR(c)          ((c)->blk_loop.itervar)
 457 #  define CX_ITERDATA_SET(cx,ivar)                                      \
 458         if ((cx->blk_loop.itervar = (SV**)(ivar)))                      \
 459             cx->blk_loop.itersave = SvREFCNT_inc(*CxITERVAR(cx));       \
 460         else                                                            \
 461             cx->blk_loop.itersave = NULL;
 462 #endif
 463
 464 #ifdef USE_ITHREADS
 465 #  define PUSHLOOP_OP_NEXT              /* No need to do anything.  */
 466 #  define CX_LOOP_NEXTOP_GET(cx)        ((cx)->blk_loop.my_op->op_nextop + 0)
 467 #else
 468 #  define PUSHLOOP_OP_NEXT              cx->blk_loop.next_op = cLOOP->op_nextop
 469 #  define CX_LOOP_NEXTOP_GET(cx)        ((cx)->blk_loop.next_op + 0)
 470 #endif
 471
 472 #define PUSHLOOP(cx, dat, s)                                            \
 473         cx->blk_loop.label = PL_curcop->cop_label;                      \
 474         cx->blk_loop.resetsp = s - PL_stack_base;                       \
 475         cx->blk_loop.my_op = cLOOP;                                     \
 476         PUSHLOOP_OP_NEXT;                                               \
 477         cx->blk_loop.iterlval = NULL;                                   \
 478         cx->blk_loop.iterary = NULL;                                    \
 479         cx->blk_loop.iterix = -1;                                       \
 480         CX_ITERDATA_SET(cx,dat);
 481
 482 #define POPLOOP(cx)                                                     \
 483         SvREFCNT_dec(cx->blk_loop.iterlval);                            \
 484         if (CxITERVAR(cx)) {                                            \
 485             if (SvPADMY(cx->blk_loop.itersave)) {                       \
 486                 SV ** const s_v_p = CxITERVAR(cx);                      \
 487                 sv_2mortal(*s_v_p);                                     \
 488                 *s_v_p = cx->blk_loop.itersave;                         \
 489             }                                                           \
 490             else {                                                      \
 491                 SvREFCNT_dec(cx->blk_loop.itersave);                    \
 492             }                                                           \
 493         }                                                               \
 494         if (cx->blk_loop.iterary && cx->blk_loop.iterary != PL_curstack)\
 495             SvREFCNT_dec(cx->blk_loop.iterary);
 496
 497 /* given/when context */
 498 struct block_givwhen {
 499         OP *leave_op;
 500 };
 501
 502 #define PUSHGIVEN(cx)                                                   \
 503         cx->blk_givwhen.leave_op = cLOGOP->op_other;
 504
 505 #define PUSHWHEN PUSHGIVEN
 506
 507 /* context common to subroutines, evals and loops */
 508 struct block {
 509     U16         blku_type;      /* what kind of context this is */
 510     U8          blku_gimme;     /* is this block running in list context? */
 511     U8          blku_spare;     /* Padding to match with struct subst */
 512     I32         blku_oldsp;     /* stack pointer to copy stuff down to */
 513     COP *       blku_oldcop;    /* old curcop pointer */
 514     I32         blku_oldmarksp; /* mark stack index */
 515     I32         blku_oldscopesp;        /* scope stack index */
 516     PMOP *      blku_oldpm;     /* values of pattern match vars */
 517
 518     union {
 519         struct block_sub        blku_sub;
 520         struct block_eval       blku_eval;
 521         struct block_loop       blku_loop;
 522         struct block_givwhen    blku_givwhen;
 523     } blk_u;
 524 };
 525 #define blk_oldsp       cx_u.cx_blk.blku_oldsp
 526 #define blk_oldcop      cx_u.cx_blk.blku_oldcop
 527 #define blk_oldmarksp   cx_u.cx_blk.blku_oldmarksp
 528 #define blk_oldscopesp  cx_u.cx_blk.blku_oldscopesp
 529 #define blk_oldpm       cx_u.cx_blk.blku_oldpm
 530 #define blk_gimme       cx_u.cx_blk.blku_gimme
 531 #define blk_sub         cx_u.cx_blk.blk_u.blku_sub
 532 #define blk_eval        cx_u.cx_blk.blk_u.blku_eval
 533 #define blk_loop        cx_u.cx_blk.blk_u.blku_loop
 534 #define blk_givwhen     cx_u.cx_blk.blk_u.blku_givwhen
 535
 536 /* Enter a block. */
 537 #define PUSHBLOCK(cx,t,sp) CXINC, cx = &cxstack[cxstack_ix],            \
 538         cx->cx_type             = t,                                    \
 539         cx->blk_oldsp           = sp - PL_stack_base,                   \
 540         cx->blk_oldcop          = PL_curcop,                            \
 541         cx->blk_oldmarksp       = PL_markstack_ptr - PL_markstack,      \
 542         cx->blk_oldscopesp      = PL_scopestack_ix,                     \
 543         cx->blk_oldpm           = PL_curpm,                             \
 544         cx->blk_gimme           = (U8)gimme;                            \
 545         DEBUG_l( PerlIO_printf(Perl_debug_log, "Entering block %ld, type %s\n", \
 546                     (long)cxstack_ix, PL_block_type[CxTYPE(cx)]); )
 547
 548 /* Exit a block (RETURN and LAST). */
 549 #define POPBLOCK(cx,pm) cx = &cxstack[cxstack_ix--],                    \
 550         newsp            = PL_stack_base + cx->blk_oldsp,               \
 551         PL_curcop        = cx->blk_oldcop,                              \
 552         PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp,            \
 553         PL_scopestack_ix = cx->blk_oldscopesp,                          \
 554         pm               = cx->blk_oldpm,                               \
 555         gimme            = cx->blk_gimme;                               \
 556         DEBUG_SCOPE("POPBLOCK");                                        \
 557         DEBUG_l( PerlIO_printf(Perl_debug_log, "Leaving block %ld, type %s\n",          \
 558                     (long)cxstack_ix+1,PL_block_type[CxTYPE(cx)]); )
 559
 560 /* Continue a block elsewhere (NEXT and REDO). */
 561 #define TOPBLOCK(cx) cx  = &cxstack[cxstack_ix],                        \
 562         PL_stack_sp      = PL_stack_base + cx->blk_oldsp,               \
 563         PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp,            \
 564         PL_scopestack_ix = cx->blk_oldscopesp,                          \
 565         PL_curpm         = cx->blk_oldpm;                               \
 566         DEBUG_SCOPE("TOPBLOCK");
 567
 568 /* substitution context */
 569 struct subst {
 570     U16         sbu_type;       /* what kind of context this is */
 571     U8          sbu_once;       /* Actually both booleans, but U8 to matches */
 572     U8          sbu_rxtainted;  /* struct block */
 573     I32         sbu_iters;
 574     I32         sbu_maxiters;
 575     I32         sbu_rflags;
 576     I32         sbu_oldsave;
 577     char *      sbu_orig;
 578     SV *        sbu_dstr;
 579     SV *        sbu_targ;
 580     char *      sbu_s;
 581     char *      sbu_m;
 582     char *      sbu_strend;
 583     void *      sbu_rxres;
 584     REGEXP *    sbu_rx;
 585 };
 586 #define sb_iters        cx_u.cx_subst.sbu_iters
 587 #define sb_maxiters     cx_u.cx_subst.sbu_maxiters
 588 #define sb_rflags       cx_u.cx_subst.sbu_rflags
 589 #define sb_oldsave      cx_u.cx_subst.sbu_oldsave
 590 #define sb_once         cx_u.cx_subst.sbu_once
 591 #define sb_rxtainted    cx_u.cx_subst.sbu_rxtainted
 592 #define sb_orig         cx_u.cx_subst.sbu_orig
 593 #define sb_dstr         cx_u.cx_subst.sbu_dstr
 594 #define sb_targ         cx_u.cx_subst.sbu_targ
 595 #define sb_s            cx_u.cx_subst.sbu_s
 596 #define sb_m            cx_u.cx_subst.sbu_m
 597 #define sb_strend       cx_u.cx_subst.sbu_strend
 598 #define sb_rxres        cx_u.cx_subst.sbu_rxres
 599 #define sb_rx           cx_u.cx_subst.sbu_rx
 600
 601 #define PUSHSUBST(cx) CXINC, cx = &cxstack[cxstack_ix],                 \
 602         cx->sb_iters            = iters,                                \
 603         cx->sb_maxiters         = maxiters,                             \
 604         cx->sb_rflags           = r_flags,                              \
 605         cx->sb_oldsave          = oldsave,                              \
 606         cx->sb_once             = once,                                 \
 607         cx->sb_rxtainted        = rxtainted,                            \
 608         cx->sb_orig             = orig,                                 \
 609         cx->sb_dstr             = dstr,                                 \
 610         cx->sb_targ             = targ,                                 \
 611         cx->sb_s                = s,                                    \
 612         cx->sb_m                = m,                                    \
 613         cx->sb_strend           = strend,                               \
 614         cx->sb_rxres            = NULL,                                 \
 615         cx->sb_rx               = rx,                                   \
 616         cx->cx_type             = CXt_SUBST;                            \
 617         rxres_save(&cx->sb_rxres, rx);                                  \
 618         (void)ReREFCNT_inc(rx)
 619
 620 #define POPSUBST(cx) cx = &cxstack[cxstack_ix--];                       \
 621         rxres_free(&cx->sb_rxres);                                      \
 622         ReREFCNT_dec(cx->sb_rx)
 623
 624 struct context {
 625     union {
 626         struct block    cx_blk;
 627         struct subst    cx_subst;
 628     } cx_u;
 629 };
 630 #define cx_type cx_u.cx_subst.sbu_type
 631
 632 #define CXTYPEMASK      0xff
 633 #define CXt_NULL        0
 634 #define CXt_SUB         1
 635 #define CXt_EVAL        2
 636 #define CXt_LOOP        3
 637 #define CXt_SUBST       4
 638 #define CXt_BLOCK       5
 639 #define CXt_FORMAT      6
 640 #define CXt_GIVEN       7
 641 #define CXt_WHEN        8
 642
 643 /* private flags for CXt_SUB and CXt_NULL */
 644 #define CXp_MULTICALL   0x00000400      /* part of a multicall (so don't
 645                                            tear down context on exit). */
 646
 647 /* private flags for CXt_EVAL */
 648 #define CXp_REAL        0x00000100      /* truly eval'', not a lookalike */
 649 #define CXp_TRYBLOCK    0x00000200      /* eval{}, not eval'' or similar */
 650
 651 /* private flags for CXt_LOOP */
 652 #define CXp_FOREACH     0x00000200      /* a foreach loop */
 653 #define CXp_FOR_DEF     0x00000400      /* foreach using $_ */
 654 #ifdef USE_ITHREADS
 655 #  define CXp_PADVAR    0x00000100      /* itervar lives on pad, iterdata
 656                                            has pad offset; if not set,
 657                                            iterdata holds GV* */
 658 #  define CxPADLOOP(c)  (((c)->cx_type & (CXt_LOOP|CXp_PADVAR))         \
 659                          == (CXt_LOOP|CXp_PADVAR))
 660 #endif
 661
 662 #define CxTYPE(c)       ((c)->cx_type & CXTYPEMASK)
 663 #define CxMULTICALL(c)  (((c)->cx_type & CXp_MULTICALL)                 \
 664                          == CXp_MULTICALL)
 665 #define CxREALEVAL(c)   (((c)->cx_type & (CXt_EVAL|CXp_REAL))           \
 666                          == (CXt_EVAL|CXp_REAL))
 667 #define CxTRYBLOCK(c)   (((c)->cx_type & (CXt_EVAL|CXp_TRYBLOCK))       \
 668                          == (CXt_EVAL|CXp_TRYBLOCK))
 669 #define CxFOREACH(c)    (((c)->cx_type & (CXt_LOOP|CXp_FOREACH))        \
 670                          == (CXt_LOOP|CXp_FOREACH))
 671 #define CxFOREACHDEF(c) (((c)->cx_type & (CXt_LOOP|CXp_FOREACH|CXp_FOR_DEF))\
 672                          == (CXt_LOOP|CXp_FOREACH|CXp_FOR_DEF))
 673
 674 #define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc()))
 675
 676 /*
 677 =head1 "Gimme" Values
 678 */
 679
 680 /*
 681 =for apidoc AmU||G_SCALAR
 682 Used to indicate scalar context.  See C<GIMME_V>, C<GIMME>, and
 683 L<perlcall>.
 684
 685 =for apidoc AmU||G_ARRAY
 686 Used to indicate list context.  See C<GIMME_V>, C<GIMME> and
 687 L<perlcall>.
 688
 689 =for apidoc AmU||G_VOID
 690 Used to indicate void context.  See C<GIMME_V> and L<perlcall>.
 691
 692 =for apidoc AmU||G_DISCARD
 693 Indicates that arguments returned from a callback should be discarded.  See
 694 L<perlcall>.
 695
 696 =for apidoc AmU||G_EVAL
 697
 698 Used to force a Perl C<eval> wrapper around a callback.  See
 699 L<perlcall>.
 700
 701 =for apidoc AmU||G_NOARGS
 702
 703 Indicates that no arguments are being sent to a callback.  See
 704 L<perlcall>.
 705
 706 =cut
 707 */
 708
 709 #define G_SCALAR        0
 710 #define G_ARRAY         1
 711 #define G_VOID          128     /* skip this bit when adding flags below */
 712
 713 /* extra flags for Perl_call_* routines */
 714 #define G_DISCARD       2       /* Call FREETMPS. */
 715 #define G_EVAL          4       /* Assume eval {} around subroutine call. */
 716 #define G_NOARGS        8       /* Don't construct a @_ array. */
 717 #define G_KEEPERR      16       /* Append errors to $@, don't overwrite it */
 718 #define G_NODEBUG      32       /* Disable debugging at toplevel.  */
 719 #define G_METHOD       64       /* Calling method. */
 720 #define G_FAKINGEVAL  256       /* Faking en eval context for call_sv or
 721                                    fold_constants. */
 722
 723 /* flag bits for PL_in_eval */
 724 #define EVAL_NULL       0       /* not in an eval */
 725 #define EVAL_INEVAL     1       /* some enclosing scope is an eval */
 726 #define EVAL_WARNONLY   2       /* used by yywarn() when calling yyerror() */
 727 #define EVAL_KEEPERR    4       /* set by Perl_call_sv if G_KEEPERR */
 728 #define EVAL_INREQUIRE  8       /* The code is being required. */
 729
 730 /* Support for switching (stack and block) contexts.
 731  * This ensures magic doesn't invalidate local stack and cx pointers.
 732  */
 733
 734 #define PERLSI_UNKNOWN          -1
 735 #define PERLSI_UNDEF            0
 736 #define PERLSI_MAIN             1
 737 #define PERLSI_MAGIC            2
 738 #define PERLSI_SORT             3
 739 #define PERLSI_SIGNAL           4
 740 #define PERLSI_OVERLOAD         5
 741 #define PERLSI_DESTROY          6
 742 #define PERLSI_WARNHOOK         7
 743 #define PERLSI_DIEHOOK          8
 744 #define PERLSI_REQUIRE          9
 745
 746 struct stackinfo {
 747     AV *                si_stack;       /* stack for current runlevel */
 748     PERL_CONTEXT *      si_cxstack;     /* context stack for runlevel */
 749     I32                 si_cxix;        /* current context index */
 750     I32                 si_cxmax;       /* maximum allocated index */
 751     I32                 si_type;        /* type of runlevel */
 752     struct stackinfo *  si_prev;
 753     struct stackinfo *  si_next;
 754     I32                 si_markoff;     /* offset where markstack begins for us.
 755                                          * currently used only with DEBUGGING,
 756                                          * but not #ifdef-ed for bincompat */
 757 };
 758
 759 typedef struct stackinfo PERL_SI;
 760
 761 #define cxstack         (PL_curstackinfo->si_cxstack)
 762 #define cxstack_ix      (PL_curstackinfo->si_cxix)
 763 #define cxstack_max     (PL_curstackinfo->si_cxmax)
 764
 765 #ifdef DEBUGGING
 766 #  define       SET_MARK_OFFSET \
 767     PL_curstackinfo->si_markoff = PL_markstack_ptr - PL_markstack
 768 #else
 769 #  define       SET_MARK_OFFSET NOOP
 770 #endif
 771
 772 #define PUSHSTACKi(type) \
 773     STMT_START {                                                        \
 774         PERL_SI *next = PL_curstackinfo->si_next;                       \
 775         if (!next) {                                                    \
 776             next = new_stackinfo(32, 2048/sizeof(PERL_CONTEXT) - 1);    \
 777             next->si_prev = PL_curstackinfo;                            \
 778             PL_curstackinfo->si_next = next;                            \
 779         }                                                               \
 780         next->si_type = type;                                           \
 781         next->si_cxix = -1;                                             \
 782         AvFILLp(next->si_stack) = 0;                                    \
 783         SWITCHSTACK(PL_curstack,next->si_stack);                        \
 784         PL_curstackinfo = next;                                         \
 785         SET_MARK_OFFSET;                                                \
 786     } STMT_END
 787
 788 #define PUSHSTACK PUSHSTACKi(PERLSI_UNKNOWN)
 789
 790 /* POPSTACK works with PL_stack_sp, so it may need to be bracketed by
 791  * PUTBACK/SPAGAIN to flush/refresh any local SP that may be active */
 792 #define POPSTACK \
 793     STMT_START {                                                        \
 794         dSP;                                                            \
 795         PERL_SI * const prev = PL_curstackinfo->si_prev;                \
 796         if (!prev) {                                                    \
 797             PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");         \
 798             my_exit(1);                                                 \
 799         }                                                               \
 800         SWITCHSTACK(PL_curstack,prev->si_stack);                        \
 801         /* don't free prev here, free them all at the END{} */          \
 802         PL_curstackinfo = prev;                                         \
 803     } STMT_END
 804
 805 #define POPSTACK_TO(s) \
 806     STMT_START {                                                        \
 807         while (PL_curstack != s) {                                      \
 808             dounwind(-1);                                               \
 809             POPSTACK;                                                   \
 810         }                                                               \
 811     } STMT_END
 812
 813 #define IN_PERL_COMPILETIME     (PL_curcop == &PL_compiling)
 814 #define IN_PERL_RUNTIME         (PL_curcop != &PL_compiling)
 815
 816 /*
 817 =head1 Multicall Functions
 818
 819 =for apidoc Ams||dMULTICALL
 820 Declare local variables for a multicall. See L<perlcall/Lightweight Callbacks>.
 821
 822 =for apidoc Ams||PUSH_MULTICALL
 823 Opening bracket for a lightweight callback.
 824 See L<perlcall/Lightweight Callbacks>.
 825
 826 =for apidoc Ams||MULTICALL
 827 Make a lightweight callback. See L<perlcall/Lightweight Callbacks>.
 828
 829 =for apidoc Ams||POP_MULTICALL
 830 Closing bracket for a lightweight callback.
 831 See L<perlcall/Lightweight Callbacks>.
 832
 833 =cut
 834 */
 835
 836 #define dMULTICALL \
 837     SV **newsp;                 /* set by POPBLOCK */                   \
 838     PERL_CONTEXT *cx;                                                   \
 839     CV *multicall_cv;                                                   \
 840     OP *multicall_cop;                                                  \
 841     bool multicall_oldcatch;                                            \
 842     U8 hasargs = 0              /* used by PUSHSUB */
 843
 844 #define PUSH_MULTICALL(the_cv) \
 845     STMT_START {                                                        \
 846         CV * const _nOnclAshIngNamE_ = the_cv;                          \
 847         CV * const cv = _nOnclAshIngNamE_;                              \
 848         AV * const padlist = CvPADLIST(cv);                             \
 849         ENTER;                                                          \
 850         multicall_oldcatch = CATCH_GET;                                 \
 851         SAVETMPS; SAVEVPTR(PL_op);                                      \
 852         CATCH_SET(TRUE);                                                \
 853         PUSHBLOCK(cx, CXt_SUB|CXp_MULTICALL, PL_stack_sp);              \
 854         PUSHSUB(cx);                                                    \
 855         if (++CvDEPTH(cv) >= 2) {                                       \
 856             PERL_STACK_OVERFLOW_CHECK();                                \
 857             Perl_pad_push(aTHX_ padlist, CvDEPTH(cv));                  \
 858         }                                                               \
 859         SAVECOMPPAD();                                                  \
 860         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));                       \
 861         multicall_cv = cv;                                              \
 862         multicall_cop = CvSTART(cv);                                    \
 863     } STMT_END
 864
 865 #define MULTICALL \
 866     STMT_START {                                                        \
 867         PL_op = multicall_cop;                                          \
 868         CALLRUNOPS(aTHX);                                               \
 869     } STMT_END
 870
 871 #define POP_MULTICALL \
 872     STMT_START {                                                        \
 873         LEAVESUB(multicall_cv);                                         \
 874         CvDEPTH(multicall_cv)--;                                        \
 875         POPBLOCK(cx,PL_curpm);                                          \
 876         CATCH_SET(multicall_oldcatch);                                  \
 877         LEAVE;                                                          \
 878     } STMT_END
 879
 880 /*
 881  * Local variables:
 882  * c-indentation-style: bsd
 883  * c-basic-offset: 4
 884  * indent-tabs-mode: t
 885  * End:
 886  *
 887  * ex: set ts=8 sts=4 sw=4 noet:
 888  */