From ecd16bef716034a206582fb99ed13157f545cb21 Mon Sep 17 00:00:00 2001 From: Stefan O'Rear Date: Mon, 29 Mar 2010 02:57:35 -0700 Subject: [PATCH] CALLBACKS! --- nt/callback.t | 32 +++++++++++++++++++++++ src/pmc/bkmarshal.c | 53 ++++++++++++++++++++++++++++----------- src/pmc/bkmarshal.h | 4 +-- src/pmc/p5interpreter.pmc | 2 ++ src/pmc/p5scalar.pmc | 2 +- 5 files changed, 76 insertions(+), 17 deletions(-) create mode 100644 nt/callback.t diff --git a/nt/callback.t b/nt/callback.t new file mode 100644 index 0000000..475127d --- /dev/null +++ b/nt/callback.t @@ -0,0 +1,32 @@ +# vim: ft=perl6 + +plan(6); + +pir::load_bytecode("perl5.pir"); + +sub p5($code) { + pir::compreg__ps("perl5").make_interp('sub {' ~ $code ~ '}')(); +} + +my $f1 := p5('5;'); +ok((+$f1(sub(){})) == 5, "can pass subs into p5"); + +my $f2 := p5('my $f = shift; $f->(); 4'); +ok((+$f2(sub(){})) == 4, "can call subs passed into p5"); + +my $v := 0; +my $f3 := p5('my $f = shift; $f->(5); 2'); +$f3(sub(){ $v := 3 }); +ok($v == 3, "can pass values into callbacks"); + +my $f4 := p5('my $f = shift; $f->()'); +ok((+$f4(sub(){7})) == 7, "can return values from callbacks"); + +my $f5 := p5('my ($f,$v) = @_; $f->($v*$v) - 2'); +ok((+$f5(sub($x){(+$x)+2}, 16)) == 256, "can do arithmetic with wrapped values"); + +$v := 0; +my $f6 := p5('my $f = shift; sub { $f->(shift()+1) }'); +$f6($f6($f6($f6(sub($a) { $v := +$a }))))(9); +ok($v == 13, "can deeply recurse between p5 and parrot"); + diff --git a/src/pmc/bkmarshal.c b/src/pmc/bkmarshal.c index 714bc22..a6d9d8f 100644 --- a/src/pmc/bkmarshal.c +++ b/src/pmc/bkmarshal.c @@ -33,6 +33,10 @@ src/pmc/p5marshal.c - wrap P5 and Parrot calling conventions #include "bkmarshal.h" #include "parrot/oplib/ops.h" +PARROT_WARN_UNUSED_RESULT +PARROT_CANNOT_RETURN_NULL +static CV *blizkost_wrap_callable(PARROT_INTERP, PMC *p5i, PMC *callable); + /* =item C @@ -46,8 +50,11 @@ Takes a PMC and marshals it into an SV that we can pass to Perl 5. PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL SV * -blizkost_marshal_arg(PARROT_INTERP, PerlInterpreter *my_perl, PMC *arg) { +blizkost_marshal_arg(PARROT_INTERP, PMC *p5i, PMC *arg) { struct sv *result = NULL; + PerlInterpreter *my_perl; + + GETATTR_P5Interpreter_my_perl(interp, p5i, my_perl); /* If it's a P5Scalar PMC, then we just fetch the SV from it - trivial * round-tripping. */ @@ -75,6 +82,10 @@ blizkost_marshal_arg(PARROT_INTERP, PerlInterpreter *my_perl, PMC *arg) { char *c_str = Parrot_str_to_cstring(interp, VTABLE_get_string(interp, arg)); result = sv_2mortal(newSVpv(c_str, strlen(c_str))); } + else if (VTABLE_isa(interp, arg, CONST_STRING(interp, "Sub"))) { + CV *wrapper = blizkost_wrap_callable(interp, p5i, arg); + result = sv_2mortal(newRV_inc((SV*)wrapper)); + } else if ( VTABLE_does(interp, arg, CONST_STRING(interp, "array"))) { PMC *iter; struct av *array = newAV(); @@ -82,10 +93,10 @@ blizkost_marshal_arg(PARROT_INTERP, PerlInterpreter *my_perl, PMC *arg) { while (VTABLE_get_bool(interp, iter)) { PMC *item = VTABLE_shift_pmc(interp, iter); struct sv *marshaled = - blizkost_marshal_arg(interp, my_perl, item); + blizkost_marshal_arg(interp, p5i, item); av_push( array, marshaled); } - result = newRV_inc(array); + result = newRV_inc((SV*)array); } else if ( VTABLE_does(interp, arg, CONST_STRING(interp, "hash"))) { @@ -96,11 +107,11 @@ blizkost_marshal_arg(PARROT_INTERP, PerlInterpreter *my_perl, PMC *arg) { for(i = 0; i < n; i++) { STRING *s = VTABLE_shift_string(interp, iter); char *c_str = Parrot_str_to_cstring(interp, s); - struct sv *val = blizkost_marshal_arg(interp, my_perl, + struct sv *val = blizkost_marshal_arg(interp, p5i, VTABLE_get_pmc_keyed_str(interp, arg, s)); hv_store(hash, c_str, strlen(c_str), val, 0); } - result = newRV_inc(hash); + result = newRV_inc((SV*)hash); } else { Parrot_ex_throw_from_c_args(interp, NULL, 1, @@ -163,7 +174,7 @@ blizkost_return_from_invoke(PARROT_INTERP, void *next) { } int -blizkost_slurpy_to_stack(PARROT_INTERP, PerlInterpreter *my_perl, +blizkost_slurpy_to_stack(PARROT_INTERP, PMC *p5i, PerlInterpreter *my_perl, PMC *positional, PMC *named) { int num_pos, i, stkdepth; PMC *iter; @@ -175,7 +186,7 @@ blizkost_slurpy_to_stack(PARROT_INTERP, PerlInterpreter *my_perl, num_pos = VTABLE_elements(interp, positional); for (i = 0; i < num_pos; i++) { PMC *pos_arg = VTABLE_get_pmc_keyed_int(interp, positional, i); - XPUSHs(blizkost_marshal_arg(interp, my_perl, pos_arg)); + XPUSHs(blizkost_marshal_arg(interp, p5i, pos_arg)); stkdepth++; } @@ -187,7 +198,7 @@ blizkost_slurpy_to_stack(PARROT_INTERP, PerlInterpreter *my_perl, PMC *arg_value = VTABLE_get_pmc_keyed_str(interp, named, arg_name); char *c_arg_name = Parrot_str_to_cstring(interp, arg_name); XPUSHs(sv_2mortal(newSVpv(c_arg_name, strlen(c_arg_name)))); - XPUSHs(blizkost_marshal_arg(interp, my_perl, arg_value)); + XPUSHs(blizkost_marshal_arg(interp, p5i, arg_value)); stkdepth += 2; } PUTBACK; @@ -210,7 +221,7 @@ blizkost_call_in(PARROT_INTERP, PMC *p5i, SV *what, U32 mode, PMC *positp, PUSHMARK(SP); PUTBACK; - blizkost_slurpy_to_stack(interp, my_perl, positp, namedp); + blizkost_slurpy_to_stack(interp, p5i, my_perl, positp, namedp); /* Invoke the methods. */ num_returns = call_sv(what, mode); @@ -297,7 +308,6 @@ blizkost_bind_pmc_to_sv(PerlInterpreter *my_perl, SV *sv, Parrot_pmc_gc_register(interp, target); } -#if 0 /* can't really use xsubpp here... */ static XS(blizkost_callable_trampoline) @@ -315,20 +325,35 @@ XS(blizkost_callable_trampoline) PERL_UNUSED_VAR(ax); SP -= items; + PUTBACK; args = Parrot_pmc_new(interp, enum_class_ResizablePMCArray); for (i = 0; i < items; i++) { SV *svarg = ST(i); - PMC *pmcarg = blizkost_wrap_sv(interp, p5i, result_sv); + PMC *pmcarg = blizkost_wrap_sv(interp, p5i, svarg); VTABLE_unshift_pmc(interp, args, pmcarg); } Parrot_pcc_invoke_sub_from_c_args(interp, callable, "Pf->PsPsn", args, &posret, &namret); - blizkost_slurpy_to_stack(interp, my_perl, posret, namret); + blizkost_slurpy_to_stack(interp, p5i, my_perl, posret, namret); - PUTBACK; + SPAGAIN; } -#endif +PARROT_WARN_UNUSED_RESULT +PARROT_CANNOT_RETURN_NULL +static CV * +blizkost_wrap_callable(PARROT_INTERP, PMC *p5i, PMC *callable) { + PerlInterpreter *my_perl; + CV *cv; + + GETATTR_P5Interpreter_my_perl(interp, p5i, my_perl); + + cv = newXS("blizkost_xs_wrapper", blizkost_callable_trampoline, + "bkmarshal.c"); + blizkost_bind_pmc_to_sv(my_perl, (SV*)cv, interp, p5i, callable); + + return cv; +} diff --git a/src/pmc/bkmarshal.h b/src/pmc/bkmarshal.h index 04ade62..802cb84 100644 --- a/src/pmc/bkmarshal.h +++ b/src/pmc/bkmarshal.h @@ -22,7 +22,7 @@ src/pmc/p5marshal.c - wrap P5 and Parrot calling conventions PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL -SV *blizkost_marshal_arg(PARROT_INTERP, PerlInterpreter *my_perl, PMC *arg); +SV *blizkost_marshal_arg(PARROT_INTERP, PMC *p5i, PMC *arg); PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL @@ -32,7 +32,7 @@ PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL opcode_t *blizkost_return_from_invoke(PARROT_INTERP, void *next); -int blizkost_slurpy_to_stack(PARROT_INTERP, PerlInterpreter *my_perl, +int blizkost_slurpy_to_stack(PARROT_INTERP, PMC *p5i, PerlInterpreter *my_perl, PMC *positional, PMC *named); void blizkost_call_in(PARROT_INTERP, PMC *p5i, SV *what, U32 mode, diff --git a/src/pmc/p5interpreter.pmc b/src/pmc/p5interpreter.pmc index 0e3ad57..caf97cb 100644 --- a/src/pmc/p5interpreter.pmc +++ b/src/pmc/p5interpreter.pmc @@ -93,6 +93,8 @@ Set up P5Interpreter PMC. PL_exit_flags |= PERL_EXIT_DESTRUCT_END; perl_run(my_perl); SET_ATTR_my_perl(interp, SELF, my_perl); + SET_ATTR_self(interp, SELF, SELF); + SET_ATTR_parrot_interp(interp, SELF, interp); /* We turn on auto-flush to avoid oddness in interactions between * IO systems. */ diff --git a/src/pmc/p5scalar.pmc b/src/pmc/p5scalar.pmc index 4af3059..d894b2e 100644 --- a/src/pmc/p5scalar.pmc +++ b/src/pmc/p5scalar.pmc @@ -70,7 +70,7 @@ Returns the integer value of the SV. /* -=item C +=item C Returns the number value of the SV.