perl6_return.diff

--- src/Perl6/Actions.pm.orig   2011-08-24 13:34:35.000000000 +0000
+++ src/Perl6/Actions.pm        2011-08-24 13:36:30.000000000 +0000
@@ -3790,17 +3790,18 @@ class Perl6::Actions is HLL::Actions {
     sub wrap_return_handler($past) {
         PAST::Op.new(
             :pirop('perl6_type_check_return_value 0P'),
-            PAST::Stmts.new( :signature('0Pv'),
-                PAST::Op.new(:pasttype<lexotic>, :name<RETURN>,
-                    # If we fall off the bottom, decontainerize if
-                    # rw not set.
-                    PAST::Op.new( :pirop('perl6_decontainerize_return_value PP'), $past )
-                ),
-                PAST::Op.new(:pasttype<bind_6model>,
-                    PAST::Var.new(:name<RETURN>, :scope<lexical>),
-                    PAST::Var.new(:name<&EXHAUST>, :scope<lexical>))
-            )
-        )
+           $past)
+#            PAST::Stmts.new( :signature('0Pv'),
+#                PAST::Op.new(:pasttype<lexotic>, :name<RETURN>,
+#                    # If we fall off the bottom, decontainerize if
+#                    # rw not set.
+#                    PAST::Op.new( :pirop('perl6_decontainerize_return_value PP'), $past )
+#                ),
+#                PAST::Op.new(:pasttype<bind_6model>,
+#                    PAST::Var.new(:name<RETURN>, :scope<lexical>),
+#                    PAST::Var.new(:name<&EXHAUST>, :scope<lexical>))
+#            )
+#        )
     }
 
     # Works out how to look up a type. If it's not generic we statically
--- src/core/control.pm.orig    2011-08-24 13:29:50.000000000 +0000
+++ src/core/control.pm 2011-08-24 13:22:26.000000000 +0000
@@ -32,19 +32,27 @@ my &RETURN-PARCEL := -> Mu \$parcel {
 my &return-rw := -> |$ { 
     my $parcel := 
         &RETURN-PARCEL(nqp::p6parcel(pir::perl6_current_args_rpa__PP(), Nil));
-    my Mu $return := pir::find_caller_lex__Ps('RETURN');
-    nqp::isnull($return)
-        ?? die "Attempt to return outside of any Routine"
-        !! $return($parcel);
+    Q:PIR {
+        $P0 = find_lex '$parcel'
+        perl6_return $P0 
+    };  
+    #my Mu $return := pir::find_caller_lex__Ps('RETURN');
+    #nqp::isnull($return)
+    #    ?? die "Attempt to return outside of any Routine"
+    #    !! $return($parcel);
     $parcel
 };
 my &return := -> |$ {
     my $parcel := 
         &RETURN-PARCEL(nqp::p6parcel(pir::perl6_current_args_rpa__PP(), Nil));
-    my Mu $return := pir::find_caller_lex__Ps('RETURN');
-    nqp::isnull($return)
-        ?? die "Attempt to return outside of any Routine"
-        !! $return(pir::perl6_decontainerize__PP($parcel));
+    Q:PIR {
+        $P0 = find_lex '$parcel'
+        perl6_return $P0 
+    };  
+    #my Mu $return := pir::find_caller_lex__Ps('RETURN');
+    #nqp::isnull($return)
+    #    ?? die "Attempt to return outside of any Routine"
+    #    !! $return(pir::perl6_decontainerize__PP($parcel));
     $parcel
 };
 
--- src/ops/perl6.ops.orig      2011-08-24 13:30:16.000000000 +0000
+++ src/ops/perl6.ops   2011-08-24 14:36:50.000000000 +0000
@@ -27,6 +27,18 @@ static INTVAL smo_id = 0;
 /* The current dispatcher, for the next thing that wants one to take. */
 static PMC *current_dispatcher = NULL;
 
+static PMC *build_sig_object(PARROT_INTERP, ARGIN_NULLOK(PMC *signature), ARGIN(const char *sig), ...)
+{
+  PMC *sig_obj;
+  va_list args;
+
+  va_start(args, sig);
+  /* sigh, Parrot_pcc_build_sig_object_from_varargs does not have a signature arg */
+  sig_obj = Parrot_pcc_build_sig_object_from_varargs(interp, PMCNULL, sig, args);
+  va_end(args);
+  return sig_obj;
+}
+
 END_OPS_PREAMBLE
 
 /*
@@ -1088,6 +1100,61 @@ inline op encodelocaltime(out INT, in PM
     $1 = mktime(&tm);
 }
 
+inline op perl6_return(in PMC) :base_core {
+    PMC    *ctx = CURRENT_CONTEXT(interp);
+    PMC    *retctx = Parrot_pcc_get_caller_ctx(interp, ctx);   /* ignore "&return" function */
+    PMC    *parrot_sub = PMCNULL;
+    PMC    *perl6_code = PMCNULL;
+    PMC    *sig_pmc;
+    PMC    *rtype;
+    PMC    *cc;
+    PMC    *call_sig;
+    opcode_t  * dest;
+
+    while (!PMC_IS_NULL(retctx)) {
+        STRING *subid;
+       parrot_sub = Parrot_pcc_get_sub(interp, retctx);
+       GETATTR_Sub_multi_signature(interp, parrot_sub, perl6_code);
+       if (!PMC_IS_NULL(perl6_code)) {
+           /* do this sane! */
+           STRING *subname = Parrot_sub_full_sub_name(interp, parrot_sub);
+           if (Parrot_str_find_index(interp, subname, Parrot_str_new_constant(interp, "perl6;_block"), 0) != 0)
+               break;
+        }
+       retctx = Parrot_pcc_get_outer_ctx(interp, retctx);
+    }
+    if (PMC_IS_NULL(retctx)) {
+        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
+            "Attempt to return outside of any Routine");
+    }
+    /* check if we can reach the retctx via the caller chain */
+    while (retctx != ctx && !PMC_IS_NULL(ctx)) {
+        ctx = Parrot_pcc_get_caller_ctx(interp, ctx);
+    }
+    if (retctx != ctx) {
+        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
+            "Attempt to return from exhausted Routine");
+    }
+    /* found context! now type check */
+    sig_pmc = ((Rakudo_Code *)PMC_data(perl6_code))->signature;
+    rtype = ((Rakudo_Signature *)PMC_data(sig_pmc))->rtype;
+    if (!PMC_IS_NULL(rtype)) {
+        PMC *decont_value = Rakudo_cont_decontainerize(interp, $1);
+        if (!STABLE(decont_value)->type_check(interp, decont_value, rtype)) {
+            /* XXX Awesomize. */
+            Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
+                "Type check failed for return value");
+        }
+    }
+
+    /* rewind context XXX: runloop id */
+    call_sig = build_sig_object(interp, Parrot_pcc_get_signature(interp, Parrot_pcc_get_caller_ctx(interp, ctx)), "P", $1);
+    Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), call_sig);
+    cc = Parrot_pcc_get_continuation(intetp, ctx);
+    dest = VTABLE_invoke(interp, cc, NULL);
+    goto ADDRESS(dest);
+}
+
 /*
  * Local variables:
  *   c-file-style: "parrot"