exception.diff

diff --git a/src/Perl6/Actions.pm b/src/Perl6/Actions.pm
index e5e6caf..c9bda8d 100644
--- a/src/Perl6/Actions.pm
+++ b/src/Perl6/Actions.pm
@@ -3728,28 +3728,36 @@ class Perl6::Actions is HLL::Actions {
         unless $block.handlers() {
             $block.handlers([]);
         }
-        $handler := PAST::Block.new(
-            :blocktype('declaration'),
-            PAST::Var.new( :scope('parameter'), :name('$_') ),
-            PAST::Op.new( :pasttype('bind_6model'),
-                PAST::Var.new( :scope('lexical_6model'), :name('$_') ),
-                PAST::Op.new(
-                    :name('&EXCEPTION'),
-                    PAST::Var.new( :scope('lexical_6model'), :name('$_') ),
-                ),
+
+        my $handler_start := PAST::Stmts.new(
+            PAST::Op.new( :pasttype('bind'),
+                PAST::Var.new( :scope('register'), :name('exception'), :isdecl(1) ),
+                PAST::Var.new( :scope('parameter') ),
             ),
-            PAST::Var.new( :scope('lexical_6model'), :name('$/'), :isdecl(1) ),
             PAST::Op.new( :pasttype('bind_6model'),
-                PAST::Var.new( :scope('lexical_6model'), :name('$!'), :isdecl(1) ),
+                PAST::Var.new( :scope('lexical_6model'), :name('$_'), :isdecl(1) ),
+                PAST::Op.new( :name('&EXCEPTION'), PAST::Var.new( :scope('register'), :name('exception') ) ),
+            ),
+            PAST::Op.new( :pirop('perl6_container_store__0PP'),
+                PAST::Op.new( :pirop('find_lex_skip_current Ps'), '$!'),
                 PAST::Var.new( :scope('lexical_6model'), :name('$_') ),
             ),
-            PAST::Op.new( :pasttype('call'),
-                $handler,
-            ));
-        $handler.symbol('$_', :scope('lexical_6model'));
-        $handler.symbol('$!', :scope('lexical_6model'));
+            PAST::Var.new( :scope('lexical_6model'), :name('$!'), :isdecl(1) ),
+            PAST::Var.new( :scope('lexical_6model'), :name('$/'), :isdecl(1) ),
+        );
+        $handler<past_block>[1].unshift($handler_start);
+        $handler<past_block>[1].push(PAST::Op.new( :inline("    rethrow_skipnextctx exception")));
+
+        unless $handler<past_block>.handlers() {
+            $handler<past_block>.handlers([]);
+        }
+        $handler<past_block>.handlers.unshift(
+            PAST::Control.new( PAST::Op.new( :inline("    rethrow_skipnextctx exception")) )
+        );
+
+
         $handler := PAST::Stmts.new(
-            PAST::Op.new( :pasttype('call'),
+            PAST::Op.new( :pirop('invoke_catchhandler__vPP'),
                 $handler,
                 PAST::Var.new( :scope('register'), :name('exception') ),
             ),
diff --git a/src/ops/perl6.ops b/src/ops/perl6.ops
index a5d04f1..3aeb085 100644
--- a/src/ops/perl6.ops
+++ b/src/ops/perl6.ops
@@ -11,6 +11,8 @@ BEGIN_OPS_PREAMBLE
 #include "pmc_class.h"
 #include "pmc_callcontext.h"
 #include "pmc_sub.h"
+#include "pmc_continuation.h"
+#include "pmc_exception.h"
 #include "../binder/bind.h"
 #include "../binder/multidispatch.h"
 #include "../binder/container.h"
@@ -1100,6 +1102,88 @@ inline op encodelocaltime(out INT, in PMC) :base_core {
     $1 = mktime(&tm);
 }

+
+/*
+
+=item rethrow_skipnextctx(in PMC)
+
+Rethrow an exception, but skip the remaining handlers of the current
+context plus all handlers of the caller context. We use this to bypass
+the original handler when en exception occures in an CATCH/CONTROL
+block.
+
+=cut
+
+*/
+inline op rethrow_skipnextctx(in PMC) :base_core {
+    PMC      *except = $1;
+    opcode_t *dest;
+    STRING   *handler_iter_str = Parrot_str_new_constant(interp, "handler_iter");
+    PMC      *ctx = CURRENT_CONTEXT(interp);
+    PMC      *cont = Parrot_pcc_get_continuation(interp, ctx);
+    PMC      *next_ctx = PMCNULL;
+    /* this used to be simply Parrot_pcc_get_caller_ctx(interp, ctx)
+     * with the invoke_catchhandler opcode, we have to use the context from
+     * the return continuation, as it may be different from the caller
+     */
+    if (!PMC_IS_NULL(cont))
+        GETATTR_Continuation_to_ctx(interp, cont, next_ctx);
+    if (PMC_IS_NULL(next_ctx))
+        next_ctx = Parrot_pcc_get_caller_ctx(interp, ctx);
+    VTABLE_set_attr_str(interp, except, handler_iter_str, PMCNULL);
+    VTABLE_set_pointer(interp, except, next_ctx);
+    dest = Parrot_ex_rethrow_from_op(interp, except);
+    goto ADDRESS(dest);
+}
+
+
+/*
+
+=item invoke_catchhandler(invar PMC, in PMC)
+
+works like invoke, but takes a parrot exception as second argument.
+The perl6 spec says that the catchhandler's call chain must include
+the callframes from the exception, so we do some context fiddling
+here. When the catchhandler returns, it uses the continuation that
+points to the original callchain.
+Note that exceptions in the catchhandler must be caught and
+possibly rethrown with rethrow_skipnextctx, otherwise the handlers
+from the exception will pick them up.
+
+=cut
+
+*/
+inline op invoke_catchhandler(invar PMC, in PMC) :flow {
+    PMC      * p        = $1;
+    PMC      * ctx      = CURRENT_CONTEXT(interp);
+    opcode_t * dest     = expr NEXT();
+    PMC      * call_obj = Parrot_pcc_build_call_from_c_args(interp, PMCNULL, "P", $2);
+    PMC      * cont     = pmc_new(interp, enum_class_Continuation);
+    PMC      * ectx     = PMCNULL;
+
+    VTABLE_set_pointer(interp, cont, dest);
+    Parrot_pcc_set_pc(interp, ctx, dest);
+    /* now the tricky part, restore exception context */
+    GETATTR_Exception_thrower(interp, $2, ectx);
+    if (!PMC_IS_NULL(ectx) && ectx != ctx) {
+        /* make sure that the current context is reachable, just in case... */
+        PMC *cctx = ectx;
+        for (; !PMC_IS_NULL(cctx); cctx = Parrot_pcc_get_caller_ctx(interp, cctx))
+            if (cctx == ctx)
+                break;
+        if (cctx == ctx) {
+            /* ok, found it. now change the current context */
+            ctx = ectx;
+            Parrot_pcc_set_context(interp, ctx);
+        }
+    }
+    interp->current_cont = cont;
+    Parrot_pcc_set_signature(interp, ctx, call_obj);
+    dest = VTABLE_invoke(interp, p, dest);
+    goto ADDRESS(dest);
+}
+
+
 /*
  * Local variables:
  *   c-file-style: "parrot"