Author: leo
Date: Mon Nov 14 04:42:14 2005
New Revision: 9968
Modified:
trunk/classes/closure.pmc
trunk/classes/sub.pmc
trunk/imcc/pbc.c
trunk/include/parrot/sub.h
trunk/ops/experimental.ops
trunk/src/sub.c
trunk/t/op/lexicals.t
Log:
lexicals 20 - closures but now really
* fix closure handling
* newclosure clones an existing sub and remembers outer_ctx
* mark the outer_ctx for closure in mark_context
* create lex_info too, if sub has just :outer but no .lex
* test
I hope it's now really correct ;-)
Modified: trunk/classes/closure.pmc
==============================================================================
--- trunk/classes/closure.pmc (original)
+++ trunk/classes/closure.pmc Mon Nov 14 04:42:14 2005
@@ -58,7 +58,10 @@ Marks the closure as live.
void mark () {
struct Parrot_sub * sub = PMC_sub(SELF);
SUPER();
- mark_stack(INTERP, sub->pad_stack);
+ if (sub->pad_stack)
+ mark_stack(INTERP, sub->pad_stack);
+ if (sub->outer_ctx)
+ mark_context(INTERP, sub->outer_ctx);
}
Modified: trunk/classes/sub.pmc
==============================================================================
--- trunk/classes/sub.pmc (original)
+++ trunk/classes/sub.pmc Mon Nov 14 04:42:14 2005
@@ -365,6 +365,8 @@ create_ctx:
enum_class_LexPad),
sub->lex_info);
VTABLE_set_pointer(INTERP, context->lex_pad, context);
+ if (!sub->outer_ctx)
+ sub->outer_ctx = caller_ctx;
}
/* switch code segment if needed */
if (INTERP->code != sub->seg) {
Modified: trunk/imcc/pbc.c
==============================================================================
--- trunk/imcc/pbc.c (original)
+++ trunk/imcc/pbc.c Mon Nov 14 04:42:14 2005
@@ -693,10 +693,14 @@ create_lexinfo(Interp *interpreter, IMC_
lex_name = constants[k]->u.string;
assert(PObj_is_string_TEST(lex_name));
(decl_func)(interpreter,
- lex_info, lex_name, r->color);
+ lex_info, lex_name, r->color);
}
}
}
+ if (!lex_info && unit->outer) {
+ lex_info = pmc_new_noinit(interpreter, lex_info_id);
+ VTABLE_init_pmc(interpreter, lex_info, sub);
+ }
return lex_info;
}
Modified: trunk/include/parrot/sub.h
==============================================================================
--- trunk/include/parrot/sub.h (original)
+++ trunk/include/parrot/sub.h Mon Nov 14 04:42:14 2005
@@ -65,6 +65,7 @@ typedef struct Parrot_sub {
PMC *lex_info; /* LexInfo PMC */
PMC *outer_sub; /* :outer for closures */
PMC *eval_pmc; /* eval container / NULL */
+ parrot_context_t *outer_ctx; /* new style */
/* - end common */
@@ -91,10 +92,10 @@ typedef struct Parrot_coro {
PMC *lex_info; /* LexInfo PMC */
PMC *outer_sub; /* :outer for closures */
PMC *eval_pmc; /* eval container / NULL */
+ struct Parrot_Context *ctx; /* coroutine context */
/* - end common */
- struct Parrot_Context *ctx; /* coroutine context */
struct PackFile_ByteCode *caller_seg; /* bytecode segment */
} * parrot_coro_t;
@@ -141,6 +142,7 @@ int Parrot_Context_info(Interp *interpre
STRING* Parrot_Context_infostr(Interp *interpreter, parrot_context_t *);
PMC* Parrot_find_pad(Interp*, STRING *lex_name);
+PMC* parrot_new_closure(Interp*, PMC*);
#endif /* PARROT_SUB_H_GUARD */
Modified: trunk/ops/experimental.ops
==============================================================================
--- trunk/ops/experimental.ops (original)
+++ trunk/ops/experimental.ops Mon Nov 14 04:42:14 2005
@@ -231,19 +231,7 @@ Create a closure of the given subroutine
=cut
inline op newclosure(out PMC, in PMC) {
- PMC *clos;
- struct Parrot_sub *newsub;
- PMC * pad = scratchpad_get_current(interpreter);
- clos = VTABLE_clone(interpreter, $2);
- clos->vtable = Parrot_base_vtables[enum_class_Closure];
- newsub = PMC_sub(clos);
- newsub->pad_stack = new_stack(interpreter, "Pad");
- if (pad) {
- /* put the correct pad in place */
- stack_push(interpreter, &newsub->pad_stack, pad,
- STACK_ENTRY_PMC, STACK_CLEANUP_NULL);
- }
- $1 = clos;
+ $1 = parrot_new_closure(interpreter, $2);
goto NEXT();
}
###############################################################################
Modified: trunk/src/sub.c
==============================================================================
--- trunk/src/sub.c (original)
+++ trunk/src/sub.c Mon Nov 14 04:42:14 2005
@@ -39,7 +39,8 @@ mark_context(Interp* interpreter, parrot
PObj *obj;
int i;
- mark_stack(interpreter, ctx->pad_stack);
+ if (ctx->pad_stack)
+ mark_stack(interpreter, ctx->pad_stack);
mark_stack(interpreter, ctx->user_stack);
mark_stack(interpreter, ctx->control_stack);
mark_register_stack(interpreter, ctx->reg_stack);
@@ -418,7 +419,7 @@ Parrot_find_pad(Interp* interpreter, STR
{
PMC *lex_pad;
parrot_context_t *ctx;
- PMC *result, *sub, *caller, *cont;
+ PMC *result, *sub;
ctx = CONTEXT(interpreter->ctx);;
lex_pad = ctx->lex_pad;
@@ -429,28 +430,53 @@ Parrot_find_pad(Interp* interpreter, STR
result = VTABLE_get_pmc_keyed_str(interpreter, lex_pad, lex_name);
if (result)
return lex_pad;
- sub = PMC_sub(sub)->outer_sub;
- /*
- * locate outer in call chain
- */
- while (1) {
- cont = ctx->current_cont;
- if (!cont)
- return NULL;
- ctx = PMC_cont(cont)->to_ctx;
- if (!ctx)
- return NULL;
- caller = ctx->current_sub;
- if (caller == sub)
- break;
- }
+ ctx = PMC_sub(sub)->outer_ctx;
+ if (!ctx)
+ return NULL;
lex_pad = ctx->lex_pad;
if (PMC_IS_NULL(lex_pad))
return NULL;
+ sub = PMC_sub(sub)->outer_sub;
}
return NULL;
}
+PMC*
+parrot_new_closure(Interp *interpreter, PMC *sub_pmc)
+{
+ PMC *clos_pmc;
+ struct Parrot_sub *clos, *sub;
+ PMC *pad, *cont;
+ parrot_context_t *ctx;
+
+ clos_pmc = VTABLE_clone(interpreter, sub_pmc);
+ clos_pmc->vtable = Parrot_base_vtables[enum_class_Closure];
+ sub = PMC_sub(sub_pmc);
+ clos = PMC_sub(clos_pmc);
+ if (!PMC_IS_NULL(sub->lex_info)) {
+ /* new style closures */
+ ctx = CONTEXT(interpreter->ctx);
+ cont = ctx->current_cont;
+ /* preserve this frame by converting the continuation */
+ cont->vtable = Parrot_base_vtables[enum_class_Continuation];
+ /* remember this (the :outer) ctx in the closure */
+ clos->outer_ctx = ctx;
+ /* the closure refs now this context too */
+ ctx->ref_count++;
+ }
+ else {
+ /* old scratchpad */
+
+ pad = scratchpad_get_current(interpreter);
+ clos->pad_stack = new_stack(interpreter, "Pad");
+ if (pad) {
+ /* put the correct pad in place */
+ stack_push(interpreter, &clos->pad_stack, pad,
+ STACK_ENTRY_PMC, STACK_CLEANUP_NULL);
+ }
+ }
+ return clos_pmc;
+}
/*
=back
Modified: trunk/t/op/lexicals.t
==============================================================================
--- trunk/t/op/lexicals.t (original)
+++ trunk/t/op/lexicals.t Mon Nov 14 04:42:14 2005
@@ -16,7 +16,7 @@ Tests various lexical scratchpad operati
=cut
-use Parrot::Test tests => 32;
+use Parrot::Test tests => 33;
output_is(<<'CODE', <<'OUTPUT', '.lex parsing - PASM');
.pcc_sub main:
@@ -324,6 +324,63 @@ ex_main_a
ex_main_a
OUTPUT
+pir_output_is(<<'CODE', <<'OUTPUT', 'closure 3');
+# sub foo {
+# my ($n) = @_;
+# sub {$n += shift}
+# }
+# my $f = foo(5);
+# print &$f(3), "\n";
+# my $g = foo(20);
+# print &$g(3), "\n";
+# print &$f(3), "\n";
+# print &$g(4), "\n";
+
+.sub foo
+ .param pmc arg
+ .local pmc n
+ .lex '$n', n
+ n = arg
+ .const .Sub anon = "anon"
+ $P0 = newclosure anon
+ .return ($P0)
+.end
+
+.sub anon :outer(foo)
+ .param pmc arg
+ $P0 = find_lex '$n'
+ # in practice we need copying the arg but as it is passed
+ # as native int, we already have a fresh pmc
+ $P0 += arg
+ .return ($P0)
+.end
+
+.sub main :main
+ .local pmc f, g
+ .lex '$f', f
+ .lex '$g', g
+ f = foo(5)
+ $P0 = f(3)
+ print $P0
+ print "\n"
+ g = foo(20)
+ $P0 = g(3)
+ print $P0
+ print "\n"
+ $P0 = f(3)
+ print $P0
+ print "\n"
+ $P0 = g(4)
+ print $P0
+ print "\n"
+.end
+CODE
+8
+23
+11
+27
+OUTPUT
+
pir_output_like(<<'CODE', <<'OUTPUT', 'get non existing');
.sub "main"
.lex 'a', $P0
