1 /* cop.h 2 * 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 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 two ops OP_NEXTSTATE and OP_DBSTATE, 10 * 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 at %s:%d\n", \ 103 (void*)&cur_env, (void*)PL_top_env, \ 104 __FILE__, __LINE__)); \ 105 cur_env.je_prev = PL_top_env; \ 106 OP_REG_TO_MEM; \ 107 cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, SCOPE_SAVES_SIGNAL_MASK); \ 108 OP_MEM_TO_REG; \ 109 PL_top_env = &cur_env; \ 110 cur_env.je_mustcatch = FALSE; \ 111 (v) = cur_env.je_ret; \ 112 } STMT_END 113 114 #define JMPENV_POP \ 115 STMT_START { \ 116 DEBUG_l(Perl_deb(aTHX_ "popping jumplevel was %p, now %p at %s:%d\n", \ 117 (void*)PL_top_env, (void*)cur_env.je_prev, \ 118 __FILE__, __LINE__)); \ 119 assert(PL_top_env == &cur_env); \ 120 PL_top_env = cur_env.je_prev; \ 121 } STMT_END 122 123 #define JMPENV_JUMP(v) \ 124 STMT_START { \ 125 OP_REG_TO_MEM; \ 126 if (PL_top_env->je_prev) \ 127 PerlProc_longjmp(PL_top_env->je_buf, (v)); \ 128 if ((v) == 2) \ 129 PerlProc_exit(STATUS_EXIT); \ 130 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); \ 131 PerlProc_exit(1); \ 132 } STMT_END 133 134 #define CATCH_GET (PL_top_env->je_mustcatch) 135 #define CATCH_SET(v) (PL_top_env->je_mustcatch = (v)) 136 137 138 #include "mydtrace.h" 139 140 struct cop { 141 BASEOP 142 /* On LP64 putting this here takes advantage of the fact that BASEOP isn't 143 an exact multiple of 8 bytes to save structure padding. */ 144 line_t cop_line; /* line # of this command */ 145 /* label for this construct is now stored in cop_hints_hash */ 146 #ifdef USE_ITHREADS 147 char * cop_stashpv; /* package line was compiled in */ 148 char * cop_file; /* file name the following line # is from */ 149 #else 150 HV * cop_stash; /* package line was compiled in */ 151 GV * cop_filegv; /* file the following line # is from */ 152 #endif 153 U32 cop_hints; /* hints bits from pragmata */ 154 U32 cop_seq; /* parse sequence number */ 155 /* Beware. mg.c and warnings.pl assume the type of this is STRLEN *: */ 156 STRLEN * cop_warnings; /* lexical warnings bitmask */ 157 /* compile time state of %^H. See the comment in op.c for how this is 158 used to recreate a hash to return from caller. */ 159 struct refcounted_he * cop_hints_hash; 160 }; 161 162 #ifdef USE_ITHREADS 163 # define CopFILE(c) ((c)->cop_file) 164 # define CopFILEGV(c) (CopFILE(c) \ 165 ? gv_fetchfile(CopFILE(c)) : NULL) 166 167 # ifdef NETWARE 168 # define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) 169 # define CopFILE_setn(c,pv,l) ((c)->cop_file = savepv((pv),(l))) 170 # else 171 # define CopFILE_set(c,pv) ((c)->cop_file = savesharedpv(pv)) 172 # define CopFILE_setn(c,pv,l) ((c)->cop_file = savesharedpvn((pv),(l))) 173 # endif 174 175 # define CopFILESV(c) (CopFILE(c) \ 176 ? GvSV(gv_fetchfile(CopFILE(c))) : NULL) 177 # define CopFILEAV(c) (CopFILE(c) \ 178 ? GvAV(gv_fetchfile(CopFILE(c))) : NULL) 179 # ifdef DEBUGGING 180 # define CopFILEAVx(c) (assert(CopFILE(c)), \ 181 GvAV(gv_fetchfile(CopFILE(c)))) 182 # else 183 # define CopFILEAVx(c) (GvAV(gv_fetchfile(CopFILE(c)))) 184 # endif 185 # define CopSTASHPV(c) ((c)->cop_stashpv) 186 187 # ifdef NETWARE 188 # define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : NULL)) 189 # else 190 # define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = savesharedpv(pv)) 191 # endif 192 193 # define CopSTASH(c) (CopSTASHPV(c) \ 194 ? gv_stashpv(CopSTASHPV(c),GV_ADD) : NULL) 195 # define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME_get(hv) : NULL) 196 # define CopSTASH_eq(c,hv) ((hv) && stashpv_hvname_match(c,hv)) 197 # ifdef NETWARE 198 # define CopSTASH_free(c) SAVECOPSTASH_FREE(c) 199 # define CopFILE_free(c) SAVECOPFILE_FREE(c) 200 # else 201 # define CopSTASH_free(c) PerlMemShared_free(CopSTASHPV(c)) 202 # define CopFILE_free(c) (PerlMemShared_free(CopFILE(c)),(CopFILE(c) = NULL)) 203 # endif 204 #else 205 # define CopFILEGV(c) ((c)->cop_filegv) 206 # define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) 207 # define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) 208 # define 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 CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) 220 # define CopSTASHPV(c) (CopSTASH(c) ? HvNAME_get(CopSTASH(c)) : NULL) 221 /* cop_stash is not refcounted */ 222 # define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) 223 # define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) 224 # define CopSTASH_free(c) 225 # define CopFILE_free(c) (SvREFCNT_dec(CopFILEGV(c)),(CopFILEGV(c) = NULL)) 226 227 #endif /* USE_ITHREADS */ 228 #define CopLABEL(c) Perl_fetch_cop_label(aTHX_ (c)->cop_hints_hash, NULL, NULL) 229 #define CopLABEL_alloc(pv) ((pv)?savepv(pv):NULL) 230 231 #define CopSTASH_ne(c,hv) (!CopSTASH_eq(c,hv)) 232 #define CopLINE(c) ((c)->cop_line) 233 #define CopLINE_inc(c) (++CopLINE(c)) 234 #define CopLINE_dec(c) (--CopLINE(c)) 235 #define CopLINE_set(c,l) (CopLINE(c) = (l)) 236 237 /* OutCopFILE() is CopFILE for output (caller, die, warn, etc.) */ 238 #define OutCopFILE(c) CopFILE(c) 239 240 /* If $[ is non-zero, it's stored in cop_hints under the key "$[", and 241 HINT_ARYBASE is set to indicate this. 242 Setting it is ineficient due to the need to create 2 mortal SVs, but as 243 using $[ is highly discouraged, no sane Perl code will be using it. */ 244 #define CopARYBASE_get(c) \ 245 ((CopHINTS_get(c) & HINT_ARYBASE) \ 246 ? SvIV(Perl_refcounted_he_fetch(aTHX_ (c)->cop_hints_hash, 0, \ 247 "$[", 2, 0, 0)) \ 248 : 0) 249 #define CopARYBASE_set(c, b) STMT_START { \ 250 if (b || ((c)->cop_hints & HINT_ARYBASE)) { \ 251 (c)->cop_hints |= HINT_ARYBASE; \ 252 if ((c) == &PL_compiling) { \ 253 SV *val = newSViv(b); \ 254 (void)hv_stores(GvHV(PL_hintgv), "$[", val); \ 255 mg_set(val); \ 256 PL_hints |= HINT_ARYBASE; \ 257 } else { \ 258 (c)->cop_hints_hash \ 259 = Perl_refcounted_he_new(aTHX_ (c)->cop_hints_hash, \ 260 newSVpvs_flags("$[", SVs_TEMP), \ 261 sv_2mortal(newSViv(b))); \ 262 } \ 263 } \ 264 } STMT_END 265 266 /* FIXME NATIVE_HINTS if this is changed from op_private (see perl.h) */ 267 #define CopHINTS_get(c) ((c)->cop_hints + 0) 268 #define CopHINTS_set(c, h) STMT_START { \ 269 (c)->cop_hints = (h); \ 270 } STMT_END 271 272 /* 273 * Here we have some enormously heavy (or at least ponderous) wizardry. 274 */ 275 276 /* subroutine context */ 277 struct block_sub { 278 OP * retop; /* op to execute on exit from sub */ 279 /* Above here is the same for sub, format and eval. */ 280 CV * cv; 281 /* Above here is the same for sub and format. */ 282 AV * savearray; 283 AV * argarray; 284 I32 olddepth; 285 PAD *oldcomppad; 286 }; 287 288 289 /* format context */ 290 struct block_format { 291 OP * retop; /* op to execute on exit from sub */ 292 /* Above here is the same for sub, format and eval. */ 293 CV * cv; 294 /* Above here is the same for sub and format. */ 295 GV * gv; 296 GV * dfoutgv; 297 }; 298 299 /* base for the next two macros. Don't use directly. 300 * Note that the refcnt of the cv is incremented twice; The CX one is 301 * decremented by LEAVESUB, the other by LEAVE. */ 302 303 #define PUSHSUB_BASE(cx) \ 304 ENTRY_PROBE(GvENAME(CvGV(cv)), \ 305 CopFILE((const COP *)CvSTART(cv)), \ 306 CopLINE((const COP *)CvSTART(cv))); \ 307 \ 308 cx->blk_sub.cv = cv; \ 309 cx->blk_sub.olddepth = CvDEPTH(cv); \ 310 cx->cx_type |= (hasargs) ? CXp_HASARGS : 0; \ 311 cx->blk_sub.retop = NULL; \ 312 if (!CvDEPTH(cv)) { \ 313 SvREFCNT_inc_simple_void_NN(cv); \ 314 SvREFCNT_inc_simple_void_NN(cv); \ 315 SAVEFREESV(cv); \ 316 } 317 318 319 #define PUSHSUB(cx) \ 320 PUSHSUB_BASE(cx) \ 321 cx->blk_u16 = PL_op->op_private & \ 322 (OPpLVAL_INTRO|OPpENTERSUB_INARGS); 323 324 /* variant for use by OP_DBSTATE, where op_private holds hint bits */ 325 #define PUSHSUB_DB(cx) \ 326 PUSHSUB_BASE(cx) \ 327 cx->blk_u16 = 0; 328 329 330 #define PUSHFORMAT(cx, retop) \ 331 cx->blk_format.cv = cv; \ 332 cx->blk_format.gv = gv; \ 333 cx->blk_format.retop = (retop); \ 334 cx->blk_format.dfoutgv = PL_defoutgv; \ 335 SvREFCNT_inc_void(cx->blk_format.dfoutgv) 336 337 #define POP_SAVEARRAY() \ 338 STMT_START { \ 339 SvREFCNT_dec(GvAV(PL_defgv)); \ 340 GvAV(PL_defgv) = cx->blk_sub.savearray; \ 341 } STMT_END 342 343 /* junk in @_ spells trouble when cloning CVs and in pp_caller(), so don't 344 * leave any (a fast av_clear(ary), basically) */ 345 #define CLEAR_ARGARRAY(ary) \ 346 STMT_START { \ 347 AvMAX(ary) += AvARRAY(ary) - AvALLOC(ary); \ 348 AvARRAY(ary) = AvALLOC(ary); \ 349 AvFILLp(ary) = -1; \ 350 } STMT_END 351 352 #define POPSUB(cx,sv) \ 353 STMT_START { \ 354 RETURN_PROBE(GvENAME(CvGV((const CV*)cx->blk_sub.cv)), \ 355 CopFILE((COP*)CvSTART((const CV*)cx->blk_sub.cv)), \ 356 CopLINE((COP*)CvSTART((const CV*)cx->blk_sub.cv))); \ 357 \ 358 if (CxHASARGS(cx)) { \ 359 POP_SAVEARRAY(); \ 360 /* abandon @_ if it got reified */ \ 361 if (AvREAL(cx->blk_sub.argarray)) { \ 362 const SSize_t fill = AvFILLp(cx->blk_sub.argarray); \ 363 SvREFCNT_dec(cx->blk_sub.argarray); \ 364 cx->blk_sub.argarray = newAV(); \ 365 av_extend(cx->blk_sub.argarray, fill); \ 366 AvREIFY_only(cx->blk_sub.argarray); \ 367 CX_CURPAD_SV(cx->blk_sub, 0) = MUTABLE_SV(cx->blk_sub.argarray); \ 368 } \ 369 else { \ 370 CLEAR_ARGARRAY(cx->blk_sub.argarray); \ 371 } \ 372 } \ 373 sv = MUTABLE_SV(cx->blk_sub.cv); \ 374 if (sv && (CvDEPTH((const CV*)sv) = cx->blk_sub.olddepth)) \ 375 sv = NULL; \ 376 } STMT_END 377 378 #define LEAVESUB(sv) \ 379 STMT_START { \ 380 if (sv) \ 381 SvREFCNT_dec(sv); \ 382 } STMT_END 383 384 #define POPFORMAT(cx) \ 385 setdefout(cx->blk_format.dfoutgv); \ 386 SvREFCNT_dec(cx->blk_format.dfoutgv); 387 388 /* eval context */ 389 struct block_eval { 390 OP * retop; /* op to execute on exit from eval */ 391 /* Above here is the same for sub, format and eval. */ 392 SV * old_namesv; 393 OP * old_eval_root; 394 SV * cur_text; 395 CV * cv; 396 JMPENV * cur_top_env; /* value of PL_top_env when eval CX created */ 397 }; 398 399 /* If we ever need more than 512 op types, change the shift from 7. 400 blku_gimme is actually also only 2 bits, so could be merged with something. 401 */ 402 403 #define CxOLD_IN_EVAL(cx) (((cx)->blk_u16) & 0x7F) 404 #define CxOLD_OP_TYPE(cx) (((cx)->blk_u16) >> 7) 405 406 #define PUSHEVAL(cx,n) \ 407 STMT_START { \ 408 assert(!(PL_in_eval & ~0x7F)); \ 409 assert(!(PL_op->op_type & ~0x1FF)); \ 410 cx->blk_u16 = (PL_in_eval & 0x7F) | ((U16)PL_op->op_type << 7); \ 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 = CxOLD_IN_EVAL(cx); \ 422 optype = CxOLD_OP_TYPE(cx); \ 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 PAD *oldcomppad; /* Also used for the GV, if targoffset is 0 */ 436 /* This is also accesible via cx->blk_loop.my_op->op_targ */ 437 PADOFFSET targoffset; 438 #else 439 OP * next_op; 440 SV ** itervar; 441 #endif 442 union { 443 struct { /* valid if type is LOOP_FOR or LOOP_PLAIN (but {NULL,0})*/ 444 AV * ary; /* use the stack if this is NULL */ 445 IV ix; 446 } ary; 447 struct { /* valid if type is LOOP_LAZYIV */ 448 IV cur; 449 IV end; 450 } lazyiv; 451 struct { /* valid if type if LOOP_LAZYSV */ 452 SV * cur; 453 SV * end; /* maxiumum value (or minimum in reverse) */ 454 } lazysv; 455 } state_u; 456 }; 457 458 #ifdef USE_ITHREADS 459 # define CxITERVAR(c) \ 460 ((c)->blk_loop.oldcomppad \ 461 ? (CxPADLOOP(c) \ 462 ? &CX_CURPAD_SV( (c)->blk_loop, (c)->blk_loop.targoffset ) \ 463 : &GvSV((GV*)(c)->blk_loop.oldcomppad)) \ 464 : (SV**)NULL) 465 # define CX_ITERDATA_SET(cx,idata,o) \ 466 if ((cx->blk_loop.targoffset = (o))) \ 467 CX_CURPAD_SAVE(cx->blk_loop); \ 468 else \ 469 cx->blk_loop.oldcomppad = (idata); 470 #else 471 # define CxITERVAR(c) ((c)->blk_loop.itervar) 472 # define CX_ITERDATA_SET(cx,ivar,o) \ 473 cx->blk_loop.itervar = (SV**)(ivar); 474 #endif 475 #define CxLABEL(c) (0 + CopLABEL((c)->blk_oldcop)) 476 #define CxHASARGS(c) (((c)->cx_type & CXp_HASARGS) == CXp_HASARGS) 477 #define CxLVAL(c) (0 + (c)->blk_u16) 478 479 #ifdef USE_ITHREADS 480 # define PUSHLOOP_OP_NEXT /* No need to do anything. */ 481 # define CX_LOOP_NEXTOP_GET(cx) ((cx)->blk_loop.my_op->op_nextop + 0) 482 #else 483 # define PUSHLOOP_OP_NEXT cx->blk_loop.next_op = cLOOP->op_nextop 484 # define CX_LOOP_NEXTOP_GET(cx) ((cx)->blk_loop.next_op + 0) 485 #endif 486 487 #define PUSHLOOP_PLAIN(cx, s) \ 488 cx->blk_loop.resetsp = s - PL_stack_base; \ 489 cx->blk_loop.my_op = cLOOP; \ 490 PUSHLOOP_OP_NEXT; \ 491 cx->blk_loop.state_u.ary.ary = NULL; \ 492 cx->blk_loop.state_u.ary.ix = 0; \ 493 CX_ITERDATA_SET(cx, NULL, 0); 494 495 #define PUSHLOOP_FOR(cx, dat, s, offset) \ 496 cx->blk_loop.resetsp = s - PL_stack_base; \ 497 cx->blk_loop.my_op = cLOOP; \ 498 PUSHLOOP_OP_NEXT; \ 499 cx->blk_loop.state_u.ary.ary = NULL; \ 500 cx->blk_loop.state_u.ary.ix = 0; \ 501 CX_ITERDATA_SET(cx, dat, offset); 502 503 #define POPLOOP(cx) \ 504 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) { \ 505 SvREFCNT_dec(cx->blk_loop.state_u.lazysv.cur); \ 506 SvREFCNT_dec(cx->blk_loop.state_u.lazysv.end); \ 507 } \ 508 if (CxTYPE(cx) == CXt_LOOP_FOR) \ 509 SvREFCNT_dec(cx->blk_loop.state_u.ary.ary); 510 511 /* given/when context */ 512 struct block_givwhen { 513 OP *leave_op; 514 }; 515 516 #define PUSHGIVEN(cx) \ 517 cx->blk_givwhen.leave_op = cLOGOP->op_other; 518 519 #define PUSHWHEN PUSHGIVEN 520 521 /* context common to subroutines, evals and loops */ 522 struct block { 523 U8 blku_type; /* what kind of context this is */ 524 U8 blku_gimme; /* is this block running in list context? */ 525 U16 blku_u16; /* used by block_sub and block_eval (so far) */ 526 I32 blku_oldsp; /* stack pointer to copy stuff down to */ 527 COP * blku_oldcop; /* old curcop pointer */ 528 I32 blku_oldmarksp; /* mark stack index */ 529 I32 blku_oldscopesp; /* scope stack index */ 530 PMOP * blku_oldpm; /* values of pattern match vars */ 531 532 union { 533 struct block_sub blku_sub; 534 struct block_format blku_format; 535 struct block_eval blku_eval; 536 struct block_loop blku_loop; 537 struct block_givwhen blku_givwhen; 538 } blk_u; 539 }; 540 #define blk_oldsp cx_u.cx_blk.blku_oldsp 541 #define blk_oldcop cx_u.cx_blk.blku_oldcop 542 #define blk_oldmarksp cx_u.cx_blk.blku_oldmarksp 543 #define blk_oldscopesp cx_u.cx_blk.blku_oldscopesp 544 #define blk_oldpm cx_u.cx_blk.blku_oldpm 545 #define blk_gimme cx_u.cx_blk.blku_gimme 546 #define blk_u16 cx_u.cx_blk.blku_u16 547 #define blk_sub cx_u.cx_blk.blk_u.blku_sub 548 #define blk_format cx_u.cx_blk.blk_u.blku_format 549 #define blk_eval cx_u.cx_blk.blk_u.blku_eval 550 #define blk_loop cx_u.cx_blk.blk_u.blku_loop 551 #define blk_givwhen cx_u.cx_blk.blk_u.blku_givwhen 552 553 /* Enter a block. */ 554 #define PUSHBLOCK(cx,t,sp) CXINC, cx = &cxstack[cxstack_ix], \ 555 cx->cx_type = t, \ 556 cx->blk_oldsp = sp - PL_stack_base, \ 557 cx->blk_oldcop = PL_curcop, \ 558 cx->blk_oldmarksp = PL_markstack_ptr - PL_markstack, \ 559 cx->blk_oldscopesp = PL_scopestack_ix, \ 560 cx->blk_oldpm = PL_curpm, \ 561 cx->blk_gimme = (U8)gimme; \ 562 DEBUG_l( PerlIO_printf(Perl_debug_log, "Entering block %ld, type %s\n", \ 563 (long)cxstack_ix, PL_block_type[CxTYPE(cx)]); ) 564 565 /* Exit a block (RETURN and LAST). */ 566 #define POPBLOCK(cx,pm) cx = &cxstack[cxstack_ix--], \ 567 newsp = PL_stack_base + cx->blk_oldsp, \ 568 PL_curcop = cx->blk_oldcop, \ 569 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp, \ 570 PL_scopestack_ix = cx->blk_oldscopesp, \ 571 pm = cx->blk_oldpm, \ 572 gimme = cx->blk_gimme; \ 573 DEBUG_SCOPE("POPBLOCK"); \ 574 DEBUG_l( PerlIO_printf(Perl_debug_log, "Leaving block %ld, type %s\n", \ 575 (long)cxstack_ix+1,PL_block_type[CxTYPE(cx)]); ) 576 577 /* Continue a block elsewhere (NEXT and REDO). */ 578 #define TOPBLOCK(cx) cx = &cxstack[cxstack_ix], \ 579 PL_stack_sp = PL_stack_base + cx->blk_oldsp, \ 580 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp, \ 581 PL_scopestack_ix = cx->blk_oldscopesp, \ 582 PL_curpm = cx->blk_oldpm; \ 583 DEBUG_SCOPE("TOPBLOCK"); 584 585 /* substitution context */ 586 struct subst { 587 U8 sbu_type; /* what kind of context this is */ 588 U8 sbu_rflags; 589 U16 sbu_rxtainted; /* matches struct block */ 590 I32 sbu_iters; 591 I32 sbu_maxiters; 592 I32 sbu_oldsave; 593 char * sbu_orig; 594 SV * sbu_dstr; 595 SV * sbu_targ; 596 char * sbu_s; 597 char * sbu_m; 598 char * sbu_strend; 599 void * sbu_rxres; 600 REGEXP * sbu_rx; 601 }; 602 #define sb_iters cx_u.cx_subst.sbu_iters 603 #define sb_maxiters cx_u.cx_subst.sbu_maxiters 604 #define sb_rflags cx_u.cx_subst.sbu_rflags 605 #define sb_oldsave cx_u.cx_subst.sbu_oldsave 606 #define sb_once cx_u.cx_subst.sbu_once 607 #define sb_rxtainted cx_u.cx_subst.sbu_rxtainted 608 #define sb_orig cx_u.cx_subst.sbu_orig 609 #define sb_dstr cx_u.cx_subst.sbu_dstr 610 #define sb_targ cx_u.cx_subst.sbu_targ 611 #define sb_s cx_u.cx_subst.sbu_s 612 #define sb_m cx_u.cx_subst.sbu_m 613 #define sb_strend cx_u.cx_subst.sbu_strend 614 #define sb_rxres cx_u.cx_subst.sbu_rxres 615 #define sb_rx cx_u.cx_subst.sbu_rx 616 617 #ifdef PERL_CORE 618 # define PUSHSUBST(cx) CXINC, cx = &cxstack[cxstack_ix], \ 619 cx->sb_iters = iters, \ 620 cx->sb_maxiters = maxiters, \ 621 cx->sb_rflags = r_flags, \ 622 cx->sb_oldsave = oldsave, \ 623 cx->sb_rxtainted = rxtainted, \ 624 cx->sb_orig = orig, \ 625 cx->sb_dstr = dstr, \ 626 cx->sb_targ = targ, \ 627 cx->sb_s = s, \ 628 cx->sb_m = m, \ 629 cx->sb_strend = strend, \ 630 cx->sb_rxres = NULL, \ 631 cx->sb_rx = rx, \ 632 cx->cx_type = CXt_SUBST | (once ? CXp_ONCE : 0); \ 633 rxres_save(&cx->sb_rxres, rx); \ 634 (void)ReREFCNT_inc(rx) 635 636 # define POPSUBST(cx) cx = &cxstack[cxstack_ix--]; \ 637 rxres_free(&cx->sb_rxres); \ 638 ReREFCNT_dec(cx->sb_rx) 639 #endif 640 641 #define CxONCE(cx) ((cx)->cx_type & CXp_ONCE) 642 643 struct context { 644 union { 645 struct block cx_blk; 646 struct subst cx_subst; 647 } cx_u; 648 }; 649 #define cx_type cx_u.cx_subst.sbu_type 650 651 /* If you re-order these, there is also an array of uppercase names in perl.h 652 and a static array of context names in pp_ctl.c */ 653 #define CXTYPEMASK 0xf 654 #define CXt_NULL 0 655 #define CXt_WHEN 1 656 #define CXt_BLOCK 2 657 /* When micro-optimising :-) keep GIVEN next to the LOOPs, as these 5 share a 658 jump table in pp_ctl.c 659 The first 4 don't have a 'case' in at least one switch statement in pp_ctl.c 660 */ 661 #define CXt_GIVEN 3 662 /* This is first so that CXt_LOOP_FOR|CXt_LOOP_LAZYIV is CXt_LOOP_LAZYIV */ 663 #define CXt_LOOP_FOR 4 664 #define CXt_LOOP_PLAIN 5 665 #define CXt_LOOP_LAZYSV 6 666 #define CXt_LOOP_LAZYIV 7 667 #define CXt_SUB 8 668 #define CXt_FORMAT 9 669 #define CXt_EVAL 10 670 #define CXt_SUBST 11 671 /* SUBST doesn't feature in all switch statements. */ 672 673 /* private flags for CXt_SUB and CXt_NULL 674 However, this is checked in many places which do not check the type, so 675 this bit needs to be kept clear for most everything else. For reasons I 676 haven't investigated, it can coexist with CXp_FOR_DEF */ 677 #define CXp_MULTICALL 0x10 /* part of a multicall (so don't 678 tear down context on exit). */ 679 680 /* private flags for CXt_SUB and CXt_FORMAT */ 681 #define CXp_HASARGS 0x20 682 683 /* private flags for CXt_EVAL */ 684 #define CXp_REAL 0x20 /* truly eval'', not a lookalike */ 685 #define CXp_TRYBLOCK 0x40 /* eval{}, not eval'' or similar */ 686 687 /* private flags for CXt_LOOP */ 688 #define CXp_FOR_DEF 0x10 /* foreach using $_ */ 689 #ifdef USE_ITHREADS 690 # define CxPADLOOP(c) ((c)->blk_loop.targoffset) 691 #endif 692 693 /* private flags for CXt_SUBST */ 694 #define CXp_ONCE 0x10 /* What was sbu_once in struct subst */ 695 696 #define CxTYPE(c) ((c)->cx_type & CXTYPEMASK) 697 #define CxTYPE_is_LOOP(c) (((c)->cx_type & 0xC) == 0x4) 698 #define CxMULTICALL(c) (((c)->cx_type & CXp_MULTICALL) \ 699 == CXp_MULTICALL) 700 #define CxREALEVAL(c) (((c)->cx_type & (CXTYPEMASK|CXp_REAL)) \ 701 == (CXt_EVAL|CXp_REAL)) 702 #define CxTRYBLOCK(c) (((c)->cx_type & (CXTYPEMASK|CXp_TRYBLOCK)) \ 703 == (CXt_EVAL|CXp_TRYBLOCK)) 704 #define CxFOREACH(c) (CxTYPE_is_LOOP(c) && CxTYPE(c) != CXt_LOOP_PLAIN) 705 #define CxFOREACHDEF(c) ((CxTYPE_is_LOOP(c) && CxTYPE(c) != CXt_LOOP_PLAIN) \ 706 && ((c)->cx_type & 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 PUSHSTACKi(PERLSI_SORT); \ 891 PUSHBLOCK(cx, CXt_SUB|CXp_MULTICALL, PL_stack_sp); \ 892 PUSHSUB(cx); \ 893 if (++CvDEPTH(cv) >= 2) { \ 894 PERL_STACK_OVERFLOW_CHECK(); \ 895 Perl_pad_push(aTHX_ padlist, CvDEPTH(cv)); \ 896 } \ 897 SAVECOMPPAD(); \ 898 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); \ 899 multicall_cv = cv; \ 900 multicall_cop = CvSTART(cv); \ 901 } STMT_END 902 903 #define MULTICALL \ 904 STMT_START { \ 905 PL_op = multicall_cop; \ 906 CALLRUNOPS(aTHX); \ 907 } STMT_END 908 909 #define POP_MULTICALL \ 910 STMT_START { \ 911 LEAVESUB(multicall_cv); \ 912 CvDEPTH(multicall_cv)--; \ 913 POPBLOCK(cx,PL_curpm); \ 914 POPSTACK; \ 915 CATCH_SET(multicall_oldcatch); \ 916 LEAVE; \ 917 SPAGAIN; \ 918 } STMT_END 919 920 /* 921 * Local variables: 922 * c-indentation-style: bsd 923 * c-basic-offset: 4 924 * indent-tabs-mode: t 925 * End: 926 * 927 * ex: set ts=8 sts=4 sw=4 noet: 928 */ 929