cop.h

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