Skip to content

Instantly share code, notes, and snippets.

@jnthn
Created July 27, 2010 23:15
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save jnthn/493036 to your computer and use it in GitHub Desktop.
Save jnthn/493036 to your computer and use it in GitHub Desktop.
diff --git a/src/Perl6/Actions.pm b/src/Perl6/Actions.pm
index 9857f75..305eb6d 100644
--- a/src/Perl6/Actions.pm
+++ b/src/Perl6/Actions.pm
@@ -64,6 +64,18 @@ method comp_unit($/, $key?) {
return 1;
}
+ # XXX To work around the role outers bug, we need to fix up the
+ # contexts marked for re-capture.
+ $mainline.unshift(PAST::Op.new(
+ :inline(' $P0 = get_hll_global "@!recapture"',
+ ' recapture_loop:',
+ ' unless $P0 goto recapture_loop_end',
+ ' $P1 = shift $P0',
+ ' fixup_outer_ctx $P1',
+ ' goto recapture_loop',
+ ' recapture_loop_end:',)
+ ));
+
$unit.loadinit.unshift(
PAST::Op.new(
:name('!UNIT_OUTER'),
diff --git a/src/Perl6/Compiler/Role.pm b/src/Perl6/Compiler/Role.pm
index 15d06ab..b45eeb9 100644
--- a/src/Perl6/Compiler/Role.pm
+++ b/src/Perl6/Compiler/Role.pm
@@ -76,7 +76,7 @@ method finish($block) {
:pasttype('callmethod'),
:name('add_method'),
$meta_reg, $obj_reg, ~$_,
- PAST::Op.new( :pasttype('callmethod'), :name('clone'), %methods{~$_}<code_ref> )
+ PAST::Op.new( :pasttype('callmethod'), :name('clone'), %methods{~$_}<code_ref> )
));
}
@@ -107,6 +107,23 @@ method finish($block) {
# Call compose to create the role object.
$decl.push(PAST::Op.new( :pasttype('callmethod'), :name('compose'), $meta_reg, $obj_reg ));
+ # XXX If it's our-scoped, we need to also save a reference to the current
+ # context since we need to fixup its outer_ctx later from the main program
+ # body. Complete band-aid that we should be able to kill in the not too
+ # distant future, but the bug is nasty.
+ if !$*SETTING_MODE && ($!scope eq 'our' || $!scope eq '') {
+ $decl.unshift(PAST::Op.new(
+ :inline(' $P0 = getinterp',
+ ' $P0 = $P0["context"]',
+ ' $P1 = get_hll_global "@!recapture"',
+ ' unless null $P1 goto got_recapture_list',
+ ' $P1 = root_new ["parrot";"ResizablePMCArray"]',
+ ' set_hll_global "@!recapture", $P1',
+ ' got_recapture_list:',
+ ' push $P1, $P0')
+ ));
+ }
+
# We need the block to get the signature, or a default one, plus the
# decl code as a body.
my $sig := pir::defined__IP($!signature) ?? $!signature !! Perl6::Compiler::Signature.new();
diff --git a/src/ops/perl6.ops b/src/ops/perl6.ops
index 0f5d315..7c68c0e 100644
--- a/src/ops/perl6.ops
+++ b/src/ops/perl6.ops
@@ -10,6 +10,7 @@ BEGIN_OPS_PREAMBLE
#include "pmc_object.h"
#include "pmc_class.h"
#include "pmc_callcontext.h"
+#include "pmc_sub.h"
#include "../pmc/pmc_p6lowlevelsig.h"
#include "../binder/bind.h"
@@ -710,6 +711,27 @@ inline op find_method_null_ok(out PMC, in PMC, in STR) :base_core {
goto NEXT();
}
+
+/*
+
+=item fixup_outer_ctx(inout PMC)
+
+=cut
+
+*/
+inline op fixup_outer_ctx(inout PMC) :base_core {
+ PMC *cur_ctx = CURRENT_CONTEXT(interp);
+ if ($1->vtable->base_type == enum_class_CallContext) {
+ Parrot_pcc_set_outer_ctx(interp, $1, cur_ctx);
+ goto NEXT();
+ }
+ else {
+ opcode_t *handler = Parrot_ex_throw_from_op_args(interp, NULL,
+ EXCEPTION_INVALID_OPERATION, "fixup_outer_ctx only valid on a context");
+ goto ADDRESS(handler);
+ }
+}
+
/*
* Local variables:
* c-file-style: "parrot"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment