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