cop.h

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