diff options
| -rw-r--r-- | embed.h | 1 | ||||
| -rw-r--r-- | ext/Opcode/Opcode.pm | 3 | ||||
| -rw-r--r-- | lib/B/Op_private.pm | 1 | ||||
| -rw-r--r-- | op.c | 101 | ||||
| -rw-r--r-- | op.h | 1 | ||||
| -rw-r--r-- | opcode.h | 23 | ||||
| -rw-r--r-- | opnames.h | 7 | ||||
| -rw-r--r-- | pp_ctl.c | 66 | ||||
| -rw-r--r-- | pp_proto.h | 3 | ||||
| -rw-r--r-- | proto.h | 5 | ||||
| -rw-r--r-- | regen/opcodes | 3 |
11 files changed, 176 insertions, 38 deletions
@@ -1269,6 +1269,7 @@ #define ck_svconst(a) Perl_ck_svconst(aTHX_ a) #define ck_tell(a) Perl_ck_tell(aTHX_ a) #define ck_trunc(a) Perl_ck_trunc(aTHX_ a) +#define ck_trycatch(a) Perl_ck_trycatch(aTHX_ a) #define closest_cop(a,b,c,d) Perl_closest_cop(aTHX_ a,b,c,d) #define cmpchain_extend(a,b,c) Perl_cmpchain_extend(aTHX_ a,b,c) #define cmpchain_finish(a) Perl_cmpchain_finish(aTHX_ a) diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm index f1b2247b07..0501fb8f39 100644 --- a/ext/Opcode/Opcode.pm +++ b/ext/Opcode/Opcode.pm @@ -344,7 +344,7 @@ invert_opset function. cond_expr flip flop andassign orassign dorassign and or dor xor - warn die lineseq nextstate scope enter leave catch + warn die lineseq nextstate scope enter leave rv2cv anoncode prototype coreargs avhvswitch anonconst @@ -435,6 +435,7 @@ These are a hotchpotch of opcodes still waiting to be considered localtime gmtime entertry leavetry -- can be used to 'hide' fatal errors + entertrycatch poptry catch leavetrycatch -- similar entergiven leavegiven enterwhen leavewhen diff --git a/lib/B/Op_private.pm b/lib/B/Op_private.pm index 480dac69a0..a5917dc300 100644 --- a/lib/B/Op_private.pm +++ b/lib/B/Op_private.pm @@ -311,6 +311,7 @@ $bits{entergiven}{0} = $bf[0]; $bits{enteriter}{3} = 'OPpITER_DEF'; @{$bits{entersub}}{5,4,0} = ($bf[8], $bf[8], 'OPpENTERSUB_INARGS'); $bits{entertry}{0} = $bf[0]; +$bits{entertrycatch}{0} = $bf[0]; $bits{enterwhen}{0} = $bf[0]; @{$bits{enterwrite}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); @{$bits{eof}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); @@ -6699,6 +6699,7 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP || type == OP_SASSIGN || type == OP_ENTERTRY + || type == OP_ENTERTRYCATCH || type == OP_CUSTOM || type == OP_NULL ); @@ -9834,27 +9835,42 @@ The C<flags> argument is currently ignored. OP * Perl_newTRYCATCHOP(pTHX_ I32 flags, OP *tryblock, OP *catchvar, OP *catchblock) { - OP *tryop, *catchop; + OP *o, *catchop; PERL_ARGS_ASSERT_NEWTRYCATCHOP; assert(catchvar->op_type == OP_PADSV); PERL_UNUSED_ARG(flags); - tryop = newUNOP(OP_ENTERTRY, OPf_SPECIAL, tryblock); + /* The returned optree is shaped as: + * LISTOP leavetrycatch + * LOGOP entertrycatch + * LISTOP poptry + * $tryblock here + * LOGOP catch + * $catchblock here + */ + + if(tryblock->op_type != OP_LINESEQ) + tryblock = op_convert_list(OP_LINESEQ, 0, tryblock); + OpTYPE_set(tryblock, OP_POPTRY); - catchop = newLOGOP(OP_CATCH, 0, - newOP(OP_NULL, 0), /* LOGOP always needs an op_first */ - catchblock); + /* Manually construct a naked LOGOP. + * Normally if we call newLOGOP the returned value is a UNOP(OP_NULL) + * containing the LOGOP we wanted as its op_first */ + catchop = (OP *)alloc_LOGOP(OP_CATCH, newOP(OP_NULL, 0), catchblock); + OpMORESIB_set(cUNOPx(catchop)->op_first, catchblock); + OpLASTSIB_set(catchblock, catchop); - /* catchblock itself is an OP_NULL; the real OP_CATCH is its op_first */ - assert(cUNOPx(catchop)->op_first->op_type == OP_CATCH); - cUNOPx(catchop)->op_first->op_targ = catchvar->op_targ; + /* Inject the catchvar's pad offset into the OP_CATCH targ */ + cLOGOPx(catchop)->op_targ = catchvar->op_targ; op_free(catchvar); - return op_append_list(OP_LEAVE, - newOP(OP_ENTER, 0), - op_append_list(OP_LINESEQ, tryop, catchop)); + /* Build the optree structure */ + o = newLISTOP(OP_LIST, 0, tryblock, catchop); + o = op_convert_list(OP_ENTERTRYCATCH, 0, o); + + return o; } /* @@ -12842,6 +12858,69 @@ Perl_ck_eval(pTHX_ OP *o) } OP * +Perl_ck_trycatch(pTHX_ OP *o) +{ + LOGOP *enter; + OP *to_free = NULL; + OP *trykid, *catchkid; + OP *catchroot, *catchstart; + + PERL_ARGS_ASSERT_CK_TRYCATCH; + + trykid = cUNOPo->op_first; + if(trykid->op_type == OP_NULL || trykid->op_type == OP_PUSHMARK) { + to_free = trykid; + trykid = OpSIBLING(trykid); + } + catchkid = OpSIBLING(trykid); + + assert(trykid->op_type == OP_POPTRY); + assert(catchkid->op_type == OP_CATCH); + + /* cut whole sibling chain free from o */ + op_sibling_splice(o, NULL, -1, NULL); + if(to_free) + op_free(to_free); + op_free(o); + + enter = alloc_LOGOP(OP_ENTERTRYCATCH, NULL, NULL); + + /* establish postfix order */ + enter->op_next = (OP*)enter; + + o = op_prepend_elem(OP_LINESEQ, (OP*)enter, trykid); + op_append_elem(OP_LINESEQ, (OP*)o, catchkid); + + OpTYPE_set(o, OP_LEAVETRYCATCH); + + /* The returned optree is actually threaded up slightly nonobviously in + * terms of its ->op_next pointers. + * + * This way, if the tryblock dies, its retop points at the OP_CATCH, but + * if it does not then its leavetry skips over that and continues + * execution past it. + */ + + /* First, link up the actual body of the catch block */ + catchroot = OpSIBLING(cUNOPx(catchkid)->op_first); + catchstart = LINKLIST(catchroot); + cLOGOPx(catchkid)->op_other = catchstart; + + o->op_next = LINKLIST(o); + + /* die within try block should jump to the catch */ + enter->op_other = catchkid; + + /* after try block that doesn't die, just skip straight to leavetrycatch */ + trykid->op_next = o; + + /* after catch block, skip back up to the leavetrycatch */ + catchroot->op_next = o; + + return o; +} + +OP * Perl_ck_exec(pTHX_ OP *o) { PERL_ARGS_ASSERT_CK_EXEC; @@ -147,7 +147,6 @@ Deprecated. Use C<GIMME_V> instead. /* On OP_DUMP, has no label */ /* On OP_UNSTACK, in a C-style for loop */ /* On OP_READLINE, it's for <<>>, not <> */ - /* On OP_ENTERTRY, this is a real try {} block. */ /* There is no room in op_flags for this one, so it has its own bit- field member (op_folded) instead. The flag is only used to tell op_convert_list to set op_folded. */ @@ -549,6 +549,9 @@ EXTCONST char* const PL_op_name[] = { "isa", "cmpchain_and", "cmpchain_dup", + "entertrycatch", + "leavetrycatch", + "poptry", "catch", "freed", }; @@ -958,6 +961,9 @@ EXTCONST char* const PL_op_desc[] = { "derived class test", "comparison chaining", "comparand shuffling", + "try {block}", + "try {block} exit", + "pop try", "catch {} block", "freed op", }; @@ -1370,6 +1376,9 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */ Perl_pp_isa, Perl_pp_cmpchain_and, Perl_pp_cmpchain_dup, + Perl_pp_entertrycatch, + Perl_pp_leavetrycatch, + Perl_pp_poptry, Perl_pp_catch, } #endif @@ -1778,6 +1787,9 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */ Perl_ck_isa, /* isa */ Perl_ck_null, /* cmpchain_and */ Perl_ck_null, /* cmpchain_dup */ + Perl_ck_trycatch, /* entertrycatch */ + Perl_ck_null, /* leavetrycatch */ + Perl_ck_null, /* poptry */ Perl_ck_null, /* catch */ } #endif @@ -2187,6 +2199,9 @@ EXTCONST U32 PL_opargs[] = { 0x00000204, /* isa */ 0x00000300, /* cmpchain_and */ 0x00000100, /* cmpchain_dup */ + 0x00000300, /* entertrycatch */ + 0x00000400, /* leavetrycatch */ + 0x00000400, /* poptry */ 0x00000300, /* catch */ }; #endif @@ -2855,6 +2870,9 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { 12, /* isa */ 0, /* cmpchain_and */ 0, /* cmpchain_dup */ + 0, /* entertrycatch */ + -1, /* leavetrycatch */ + -1, /* poptry */ 0, /* catch */ }; @@ -2874,7 +2892,7 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { */ EXTCONST U16 PL_op_private_bitdefs[] = { - 0x0003, /* scalar, prototype, refgen, srefgen, readline, regcmaybe, regcreset, regcomp, substcont, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, complement, ucfirst, lcfirst, uc, lc, quotemeta, aeach, avalues, each, pop, shift, grepstart, mapstart, mapwhile, range, and, or, dor, andassign, orassign, dorassign, argcheck, argdefelem, method, method_named, method_super, method_redir, method_redir_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, fc, anonconst, cmpchain_and, cmpchain_dup, catch */ + 0x0003, /* scalar, prototype, refgen, srefgen, readline, regcmaybe, regcreset, regcomp, substcont, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, complement, ucfirst, lcfirst, uc, lc, quotemeta, aeach, avalues, each, pop, shift, grepstart, mapstart, mapwhile, range, and, or, dor, andassign, orassign, dorassign, argcheck, argdefelem, method, method_named, method_super, method_redir, method_redir_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, fc, anonconst, cmpchain_and, cmpchain_dup, entertrycatch, catch */ 0x2fdc, 0x41b9, /* pushmark */ 0x00bd, /* wantarray, runcv */ 0x0438, 0x1a50, 0x426c, 0x3d28, 0x3505, /* const */ @@ -3352,6 +3370,9 @@ EXTCONST U8 PL_op_private_valid[] = { /* ISA */ (OPpARG2_MASK), /* CMPCHAIN_AND */ (OPpARG1_MASK), /* CMPCHAIN_DUP */ (OPpARG1_MASK), + /* ENTERTRYCATCH */ (OPpARG1_MASK), + /* LEAVETRYCATCH */ (0), + /* POPTRY */ (0), /* CATCH */ (OPpARG1_MASK), }; @@ -414,11 +414,14 @@ typedef enum opcode { OP_ISA = 397, OP_CMPCHAIN_AND = 398, OP_CMPCHAIN_DUP = 399, - OP_CATCH = 400, + OP_ENTERTRYCATCH = 400, + OP_LEAVETRYCATCH = 401, + OP_POPTRY = 402, + OP_CATCH = 403, OP_max } opcode; -#define MAXO 401 +#define MAXO 404 #define OP_FREED MAXO /* the OP_IS_* macros are optimized to a simple range check because @@ -4616,15 +4616,52 @@ PP(pp_leaveeval) return retop; } +/* Ops that implement try/catch syntax + * Note the asymmetry here: + * pp_entertrycatch does two pushblocks + * pp_leavetrycatch pops only the outer one; the inner one is popped by + * pp_poptry or by stack-unwind of die within the try block + */ + +PP(pp_entertrycatch) +{ + PERL_CONTEXT *cx; + const U8 gimme = GIMME_V; + + RUN_PP_CATCHABLY(Perl_pp_entertrycatch); + + assert(!CATCH_GET); + + Perl_pp_enter(aTHX); /* performs cx_pushblock(CXt_BLOCK, ...) */ + + save_scalar(PL_errgv); + CLEAR_ERRSV(); + + cx = cx_pushblock((CXt_EVAL|CXp_EVALBLOCK|CXp_TRY), gimme, + PL_stack_sp, PL_savestack_ix); + cx_pusheval(cx, cLOGOP->op_other, NULL); + + PL_in_eval = EVAL_INEVAL; + + return NORMAL; +} + +PP(pp_leavetrycatch) +{ + /* leavetrycatch is leave */ + return Perl_pp_leave(aTHX); +} + +PP(pp_poptry) +{ + /* poptry is leavetry */ + return Perl_pp_leavetry(aTHX); +} + PP(pp_catch) { dTARGET; - if(!SvROK(ERRSV) && !SvTRUE(ERRSV)) { - /* ERRSV is neither an object nor true, therefore no exception happened */ - return cLOGOP->op_next; - } - save_clearsv(&(PAD_SVl(PL_op->op_targ))); sv_setsv(TARG, ERRSV); CLEAR_ERRSV(); @@ -4676,22 +4713,7 @@ PP(pp_entertry) assert(!CATCH_GET); - if(PL_op->op_flags & OPf_SPECIAL) { /* a try {} block */ - PERL_CONTEXT *cx; - const U8 gimme = GIMME_V; - - save_scalar(PL_errgv); - CLEAR_ERRSV(); - - cx = cx_pushblock((CXt_EVAL|CXp_EVALBLOCK|CXp_TRY), gimme, - PL_stack_sp, PL_savestack_ix); - cx_pusheval(cx, retop, NULL); - - PL_in_eval = EVAL_INEVAL; - } - else { /* an eval {} block */ - create_eval_scope(retop, 0); - } + create_eval_scope(retop, 0); return PL_op->op_next; } @@ -4723,7 +4745,7 @@ PP(pp_leavetry) CX_LEAVE_SCOPE(cx); cx_popeval(cx); cx_popblock(cx); - retop = cx->blk_eval.retop; + retop = CxTRY(cx) ? PL_op->op_next : cx->blk_eval.retop; CX_POP(cx); CLEAR_ERRSV(); diff --git a/pp_proto.h b/pp_proto.h index 48558d31c2..a9bda73e3c 100644 --- a/pp_proto.h +++ b/pp_proto.h @@ -67,6 +67,7 @@ PERL_CALLCONV OP *Perl_pp_enteriter(pTHX); PERL_CALLCONV OP *Perl_pp_enterloop(pTHX); PERL_CALLCONV OP *Perl_pp_entersub(pTHX); PERL_CALLCONV OP *Perl_pp_entertry(pTHX); +PERL_CALLCONV OP *Perl_pp_entertrycatch(pTHX); PERL_CALLCONV OP *Perl_pp_enterwhen(pTHX); PERL_CALLCONV OP *Perl_pp_enterwrite(pTHX); PERL_CALLCONV OP *Perl_pp_eof(pTHX); @@ -144,6 +145,7 @@ PERL_CALLCONV OP *Perl_pp_leaveloop(pTHX); PERL_CALLCONV OP *Perl_pp_leavesub(pTHX); PERL_CALLCONV OP *Perl_pp_leavesublv(pTHX); PERL_CALLCONV OP *Perl_pp_leavetry(pTHX); +PERL_CALLCONV OP *Perl_pp_leavetrycatch(pTHX); PERL_CALLCONV OP *Perl_pp_leavewhen(pTHX); PERL_CALLCONV OP *Perl_pp_leavewrite(pTHX); PERL_CALLCONV OP *Perl_pp_left_shift(pTHX); @@ -192,6 +194,7 @@ PERL_CALLCONV OP *Perl_pp_padhv(pTHX); PERL_CALLCONV OP *Perl_pp_padrange(pTHX); PERL_CALLCONV OP *Perl_pp_padsv(pTHX); PERL_CALLCONV OP *Perl_pp_pipe_op(pTHX); +PERL_CALLCONV OP *Perl_pp_poptry(pTHX); PERL_CALLCONV OP *Perl_pp_pos(pTHX); PERL_CALLCONV OP *Perl_pp_postdec(pTHX); PERL_CALLCONV OP *Perl_pp_postinc(pTHX); @@ -652,6 +652,11 @@ PERL_CALLCONV OP * Perl_ck_trunc(pTHX_ OP *o) #define PERL_ARGS_ASSERT_CK_TRUNC \ assert(o) +PERL_CALLCONV OP * Perl_ck_trycatch(pTHX_ OP *o) + __attribute__warn_unused_result__; +#define PERL_ARGS_ASSERT_CK_TRYCATCH \ + assert(o) + PERL_CALLCONV void Perl_ck_warner(pTHX_ U32 err, const char* pat, ...) __attribute__format__(__printf__,pTHX_2,pTHX_3); #define PERL_ARGS_ASSERT_CK_WARNER \ diff --git a/regen/opcodes b/regen/opcodes index 2a2da77c5c..6a3f8db024 100644 --- a/regen/opcodes +++ b/regen/opcodes @@ -578,4 +578,7 @@ isa derived class test ck_isa s2 cmpchain_and comparison chaining ck_null | cmpchain_dup comparand shuffling ck_null 1 +entertrycatch try {block} ck_trycatch | +leavetrycatch try {block} exit ck_null @ +poptry pop try ck_null @ catch catch {} block ck_null | |