Skip to content

Instantly share code, notes, and snippets.

@mlschroe

mlschroe/perl6_return.diff

Created August 24, 2011 14:38
Show Gist options
  • Save mlschroe/1168212 to your computer and use it in GitHub Desktop.
Save mlschroe/1168212 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
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"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment