cvsuser 04/02/09 06:47:08
Modified: include/parrot events.h interpreter.h
ops core.ops ops.num
src events.c interpreter.c nci_test.c
t/pmc nci.t
Log:
pdd16-3
* implement Parrot_callback_D
* new_callback opcode to create the CB
* fix type handling of external_data
Revision Changes Path
1.12 +3 -2 parrot/include/parrot/events.h
Index: events.h
===================================================================
RCS file: /cvs/public/parrot/include/parrot/events.h,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -w -r1.11 -r1.12
--- events.h 7 Feb 2004 12:58:46 -0000 1.11
+++ events.h 9 Feb 2004 14:46:56 -0000 1.12
@@ -1,7 +1,7 @@
/* events.h
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: events.h,v 1.11 2004/02/07 12:58:46 leo Exp $
+ * $Id: events.h,v 1.12 2004/02/09 14:46:56 leo Exp $
* Overview:
* This api will handle parrot events
* Data Structure and Algorithms:
@@ -79,7 +79,8 @@
void disable_event_checking(Parrot_Interp);
void enable_event_checking(Parrot_Interp);
-void Parrot_new_cb_event(Parrot_Interp, PMC*sub, PMC*user, void*ext);
+void Parrot_new_cb_event(Parrot_Interp, PMC*sub, void*ext);
+void Parrot_run_callback(Parrot_Interp, PMC*sub, void*ext);
void Parrot_kill_event_loop(void);
void* Parrot_sleep_on_event(Parrot_Interp, FLOATVAL t, void* next);
1.121 +3 -2 parrot/include/parrot/interpreter.h
Index: interpreter.h
===================================================================
RCS file: /cvs/public/parrot/include/parrot/interpreter.h,v
retrieving revision 1.120
retrieving revision 1.121
diff -u -w -r1.120 -r1.121
--- interpreter.h 8 Feb 2004 19:42:04 -0000 1.120
+++ interpreter.h 9 Feb 2004 14:46:56 -0000 1.121
@@ -1,7 +1,7 @@
/* interpreter.h
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: interpreter.h,v 1.120 2004/02/08 19:42:04 leo Exp $
+ * $Id: interpreter.h,v 1.121 2004/02/09 14:46:56 leo Exp $
* Overview:
* The interpreter api handles running the operations
* Data Structure and Algorithms:
@@ -339,7 +339,8 @@
void Parrot_callback_C(void *external_data, PMC *callback_info);
void Parrot_callback_D(PMC *callback_info, void *external_data);
-PMC* Parrot_make_cb(Parrot_Interp interpreter, PMC* sub, PMC* user_data);
+PMC* Parrot_make_cb(Parrot_Interp interpreter, PMC* sub, PMC* user_data,
+ STRING* cb_signature);
typedef opcode_t *(*native_func_t)(struct Parrot_Interp * interpreter,
opcode_t * cur_opcode,
1.350 +10 -0 parrot/ops/core.ops
Index: core.ops
===================================================================
RCS file: /cvs/public/parrot/ops/core.ops,v
retrieving revision 1.349
retrieving revision 1.350
diff -u -w -r1.349 -r1.350
--- core.ops 4 Feb 2004 21:16:02 -0000 1.349
+++ core.ops 9 Feb 2004 14:47:01 -0000 1.350
@@ -1089,6 +1089,11 @@
Register the PASM sub at address $2 as a compiler for source type $1.
XXX: leo N/Y
+=item B<new_callback>(out PMC, in PMC, in PMC, in STR)
+
+Create a callback stub $1 for PASM subroutine $2 with userdata $3 and
+function signature $4.
+
=cut
inline op loadlib(out PMC, in STR) {
@@ -1153,6 +1158,11 @@
}
inline op bogus() {
+ goto NEXT();
+}
+
+op new_callback(out PMC, in PMC, in PMC, in STR) {
+ $1 = Parrot_make_cb(interpreter, $2, $3, $4);
goto NEXT();
}
1.22 +2 -0 parrot/ops/ops.num
Index: ops.num
===================================================================
RCS file: /cvs/public/parrot/ops/ops.num,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -w -r1.21 -r1.22
--- ops.num 4 Feb 2004 21:16:02 -0000 1.21
+++ ops.num 9 Feb 2004 14:47:01 -0000 1.22
@@ -1363,3 +1363,5 @@
errorson_ic 1336
errorsoff_i 1337
errorsoff_ic 1338
+new_callback_p_p_p_s 1339
+new_callback_p_p_p_sc 1340
1.34 +4 -7 parrot/src/events.c
Index: events.c
===================================================================
RCS file: /cvs/public/parrot/src/events.c,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -w -r1.33 -r1.34
--- events.c 9 Feb 2004 10:47:46 -0000 1.33
+++ events.c 9 Feb 2004 14:47:04 -0000 1.34
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: events.c,v 1.33 2004/02/09 10:47:46 leo Exp $
+$Id: events.c,v 1.34 2004/02/09 14:47:04 leo Exp $
=head1 NAME
@@ -400,7 +400,7 @@
/*
=item C<void
-Parrot_new_cb_event(Parrot_Interp, PMC*sub, PMC*user, void*ext)>
+Parrot_new_cb_event(Parrot_Interp, PMC*sub, void*ext)>
Prepare and schedul a callback event
@@ -409,12 +409,11 @@
*/
void
-Parrot_new_cb_event(Parrot_Interp interpreter, PMC* sub, PMC* user, void* ext)
+Parrot_new_cb_event(Parrot_Interp interpreter, PMC* sub, void* ext)
{
parrot_event* ev = mem_sys_allocate(sizeof(parrot_event));
ev->type = EVENT_TYPE_CALL_BACK;
ev->u.call_back.sub = sub;
- ev->u.call_back.user_data = user;
ev->u.call_back.external_data = ext;
Parrot_schedule_event(interpreter, ev);
}
@@ -1094,9 +1093,7 @@
break;
case EVENT_TYPE_CALL_BACK:
edebug((stderr, "starting user cb\n"));
- Parrot_runops_fromc_args_save(interpreter, event->u.call_back.sub,
- "PP",
- event->u.call_back.user_data,
+ Parrot_run_callback(interpreter, event->u.call_back.sub,
event->u.call_back.external_data);
break;
case EVENT_TYPE_SLEEP:
1.264 +105 -16 parrot/src/interpreter.c
Index: interpreter.c
===================================================================
RCS file: /cvs/public/parrot/src/interpreter.c,v
retrieving revision 1.263
retrieving revision 1.264
diff -u -w -r1.263 -r1.264
--- interpreter.c 7 Feb 2004 16:44:31 -0000 1.263
+++ interpreter.c 9 Feb 2004 14:47:04 -0000 1.264
@@ -1,7 +1,7 @@
/*
################################################################################
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: interpreter.c,v 1.263 2004/02/07 16:44:31 leo Exp $
+$Id: interpreter.c,v 1.264 2004/02/09 14:47:04 leo Exp $
################################################################################
=head1 NAME
@@ -1133,18 +1133,22 @@
/*
-=item C<PMC* Parrot_make_cb(Parrot_Interp interpreter, PMC* sub, PMC* user)>
+=item C<PMC* Parrot_make_cb(Parrot_Interp interpreter, PMC* sub, PMC* user
+ STRING* cb_signature)>
-Register a callback function according to pdd16
+Create a callback function according to pdd16.
=cut
*/
PMC*
-Parrot_make_cb(Parrot_Interp interpreter, PMC* sub, PMC* user_data)
+Parrot_make_cb(Parrot_Interp interpreter, PMC* sub, PMC* user_data,
+ STRING *cb_signature)
{
- PMC* interp_pmc, *cb;
+ PMC* interp_pmc, *cb, *cb_sig;
+ int type;
+ char * sig_str;
/*
* we stuff all the information into the Sub PMC and pass that
* on to the external sub
@@ -1152,11 +1156,32 @@
interp_pmc = VTABLE_get_pmc_keyed_int(interpreter, interpreter->iglobals,
(INTVAL) IGLOBALS_INTERPRETER);
VTABLE_setprop(interpreter, sub,
- string_make(interpreter, "_interpreter", 12, NULL,
- PObj_external_FLAG, NULL), interp_pmc);
+ const_string(interpreter, "_interpreter"),
+ interp_pmc);
VTABLE_setprop(interpreter, sub,
- string_make(interpreter, "_user_data", 10, NULL,
- PObj_external_FLAG, NULL), user_data);
+ const_string(interpreter, "_user_data"),
+ user_data);
+ /* only ASCII sigs supported */
+ sig_str = cb_signature->strstart;
+ if (*sig_str == 'U') {
+ type = 'D';
+ }
+ else {
+ ++sig_str;
+ if (*sig_str == 'U') {
+ type = 'C';
+ }
+ else {
+ internal_exception(1, "unhandled signature '%Ss' in make_cb",
+ cb_signature);
+ }
+ }
+
+ cb_sig = pmc_new(interpreter, enum_class_PerlString);
+ VTABLE_set_string_native(interpreter, cb_sig, cb_signature);
+ VTABLE_setprop(interpreter, sub,
+ const_string(interpreter, "_signature"),
+ cb_sig);
/*
* we are gonna passing this PMC to external code, the PMCs
* might get out of scope until the callback is called -
@@ -1172,7 +1197,15 @@
* it can be passed on with signature 'p'
*/
cb = pmc_new(interpreter, enum_class_UnManagedStruct);
+ /*
+ * we handle currently 2 types only:
+ * _C ... user_data is 2nd param
+ * _D ... user_data is 1st param
+ */
+ if (type == 'C')
PMC_data(cb) = F2DPTR(Parrot_callback_C);
+ else
+ PMC_data(cb) = F2DPTR(Parrot_callback_D);
dod_register_pmc(interpreter, cb);
return cb;
@@ -1263,17 +1296,14 @@
{
PMC *passed_interp; /* the interp that originated the CB */
- PMC *user_data; /* user really intended to get that back */
int async = 1; /* cb is hitting this sub somewhen inmidst */
/*
* 3) extract user_data, func signature, check interpreter ...
*/
passed_interp = VTABLE_getprop(interpreter, callback_info,
- string_from_cstring(interpreter, "_interpreter", 0));
+ const_string(interpreter, "_interpreter"));
if (PMC_data(passed_interp) != interpreter)
PANIC("callback gone to wrong interpreter");
- user_data = VTABLE_getprop(interpreter, callback_info,
- string_from_cstring(interpreter, "_user_data", 0));
/*
* 4) check if the call_back is synchronous:
* - if yes we are inside the NCI call
@@ -1290,8 +1320,7 @@
* then wait for the CB_EVENT_xx to finish and return the
* result
*/
- Parrot_new_cb_event(interpreter, callback_info,
- user_data, external_data);
+ Parrot_new_cb_event(interpreter, callback_info, external_data);
}
else {
/*
@@ -1300,6 +1329,66 @@
}
}
+void
+Parrot_run_callback(Parrot_Interp interpreter, PMC* sub, void* ext)
+{
+ PMC* user_data, *sig;
+ STRING* sig_str;
+ char *p;
+ char pasm_sig[4];
+ FLOATVAL d_param;
+ INTVAL i_param;
+ void* param;
+
+ user_data = VTABLE_getprop(interpreter, sub,
+ const_string(interpreter, "_user_data"));
+ sig = VTABLE_getprop(interpreter, sub,
+ const_string(interpreter, "_signature"));
+ sig_str = VTABLE_get_string(interpreter, sig);
+ p = sig_str->strstart;
+
+ pasm_sig[0] = 'v'; /* no return value supported yet */
+ pasm_sig[1] = 'P';
+ if (*p == 'U') /* user_data Z in pdd16 */
+ ++p; /* p is now type of external data */
+ switch (*p) {
+ case 'v':
+ pasm_sig[2] = 'v';
+ break;
+ case '2':
+ case '3':
+ case '4':
+ case 'l':
+ case 'i':
+ case 's':
+ case 'c':
+ pasm_sig[2] = 'I';
+ i_param = *(INTVAL*) ext;
+ param = &i_param;
+ break;
+ case 'f':
+ case 'd':
+ pasm_sig[2] = 'N';
+ d_param = *(FLOATVAL*) ext;
+ param = &d_param;
+ break;
+#if 0
+ case 'p':
+ case 'P':
+ pasm_sig[2] = 'P';
+ break;
+#endif
+ case 't':
+ pasm_sig[2] = 'S';
+ param = string_from_cstring(interpreter, ext, 0);
+ break;
+ default:
+ internal_exception(1, "unhandled sig char '%c' in run_cb");
+ }
+ pasm_sig[3] = '\0';
+ Parrot_runops_fromc_args_save(interpreter, sub, pasm_sig,
+ user_data, param);
+}
/*
=item C<void Parrot_callback_C(void *external_data, PMC *callback_info)>
1.21 +12 -1 parrot/src/nci_test.c
Index: nci_test.c
===================================================================
RCS file: /cvs/public/parrot/src/nci_test.c,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -w -r1.20 -r1.21
--- nci_test.c 7 Feb 2004 12:58:53 -0000 1.20
+++ nci_test.c 9 Feb 2004 14:47:05 -0000 1.21
@@ -23,6 +23,9 @@
typedef void (*cb_C1_func)(const char*, void*);
void nci_cb_C1(cb_C1_func, void*);
+typedef void (*cb_D1_func)(void*, const char*);
+void nci_cb_D1(cb_D1_func, void*);
+
double nci_dd(double d) {
return d * 2.0;
}
@@ -231,9 +234,17 @@
void
nci_cb_C1(cb_C1_func cb, void* user_data)
{
- const char *result = "succeded";
+ const char *result = "succeeded";
/* call the cb synchronously */
(cb)(result, user_data);
+}
+
+void
+nci_cb_D1(cb_D1_func cb, void* user_data)
+{
+ const char *result = "succeeded";
+ /* call the cb synchronously */
+ (cb)(user_data, result);
}
#ifdef TEST
1.31 +70 -16 parrot/t/pmc/nci.t
Index: nci.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/nci.t,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -w -r1.30 -r1.31
--- nci.t 8 Feb 2004 19:42:09 -0000 1.30
+++ nci.t 9 Feb 2004 14:47:07 -0000 1.31
@@ -1,4 +1,4 @@
-use Parrot::Test tests => 27;
+use Parrot::Test tests => 28;
use Parrot::Config;
print STDERR $PConfig{jitcpuarch}, " JIT CPU\n";
@@ -824,39 +824,33 @@
OUTPUT
output_is(<<'CODE', <<'OUTPUT', "nci_cb_C1");
- bounds 1 # no JIT yet
+
# we need a flag if the call_back is already done
new P10, .PerlInt
store_global "cb_done", P10
# first attempt - create cb manually (this step will be hidden later)
- newsub P5, .Sub, _call_back
- null P1
- dlfunc P0, P1, "Parrot_make_cb", "PIPP"
- print "ok 1\n"
+ newsub P6, .Sub, _call_back
# prepare user data
- new P6, .PerlInt
- set P6, 42
- # preserve the Sub
- set P7, P5
- # create callback (=> P5)
- invoke
+ new P7, .PerlInt
+ set P7, 42
+ new_callback P5, P6, P7, "tU" # Z in pdd16
+ print "ok 1\n"
# now call the external sub, that takes a call_back and user_data
loadlib P1, "libnci"
dlfunc P0, P1, "nci_cb_C1", "vpP"
print "ok 2\n"
# P5 is the cb
- # get user_data i.e. the Sub
- set P6, P7
+ # P6 is user_data - the Sub
invoke
# call_back will be called at any time
# so spin a bit
set I20, 0
loop:
inc I20
- #or sleep 0.01 and loop only a few times
+ sleep 0.01
find_global P11, "cb_done"
if P11, fin
- gt I20, 100000, err
+ gt I20, 10, err
branch loop
fin:
print "done.\n"
@@ -870,6 +864,9 @@
print "user data: "
print P5
print "\n"
+ print "external data: "
+ print S5
+ print "\n"
find_global P12, "cb_done"
inc P12
invoke P1
@@ -879,9 +876,66 @@
ok 2
in callback
user data: 42
+external data: succeeded
done.
OUTPUT
+output_is(<<'CODE', <<'OUTPUT', "nci_cb_D1");
+
+ # we need a flag if the call_back is already done
+ new P10, .PerlInt
+ store_global "cb_done", P10
+ # first attempt - create cb manually (this step will be hidden later)
+ newsub P6, .Sub, _call_back
+ # prepare user data
+ new P7, .PerlInt
+ set P7, 42
+ new_callback P5, P6, P7, "Ut" # Z in pdd16
+ print "ok 1\n"
+ # now call the external sub, that takes a call_back and user_data
+ loadlib P1, "libnci"
+ dlfunc P0, P1, "nci_cb_D1", "vpP"
+ print "ok 2\n"
+ # P5 is the cb
+ # P6 is user_data - the Sub
+ invoke
+ # call_back will be called at any time
+ # so spin a bit
+ set I20, 0
+loop:
+ inc I20
+ sleep 0.01
+ find_global P11, "cb_done"
+ if P11, fin
+ gt I20, 10, err
+ branch loop
+fin:
+ print "done.\n"
+ end
+err:
+ print "cb didnt run\n"
+ end
+
+_call_back:
+ print "in callback\n"
+ print "user data: "
+ print P5
+ print "\n"
+ print "external data: "
+ print S5
+ print "\n"
+ find_global P12, "cb_done"
+ inc P12
+ invoke P1
+
+CODE
+ok 1
+ok 2
+in callback
+user data: 42
+external data: succeeded
+done.
+OUTPUT
} # SKIP
1;
