A totally new optree structure for try/catch involving three new optypes

11 files changed, 176 insertions, 38 deletions

diff --git a/embed.h b/embed.h
index 894fd46f6a..bb592b1d4e 100644
--- a/embed.h
+++ b/embed.h
@@ -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]);
diff --git a/op.c b/op.c
index e791032430..ae7c3209d8 100644
--- a/op.c
+++ b/op.c
@@ -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;
diff --git a/op.h b/op.h
index c6de0d19fa..cd3926ddc5 100644
--- a/op.h
+++ b/op.h
@@ -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.  */
diff --git a/opcode.h b/opcode.h
index dc4254cb4e..c808bee65c 100644
--- a/opcode.h
+++ b/opcode.h
@@ -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),
 
 };
diff --git a/opnames.h b/opnames.h
index 57d29583af..f6c1552a52 100644
--- a/opnames.h
+++ b/opnames.h
@@ -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
diff --git a/pp_ctl.c b/pp_ctl.c
index 6ef2ba17bb..9d7de39bcf 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -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);
diff --git a/proto.h b/proto.h
index d29b60057e..3d2e6b58c1 100644
--- a/proto.h
+++ b/proto.h
@@ -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		|