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