conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

C callbacks now reach the C point where they should make the call 

back into Scheme land.
This commit is contained in:
Abdulaziz Ghuloum 2008-09-20 01:58:57 -04:00
parent 31f5f88889
commit 06fd988a17
6 changed files with 151 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
scheme/ikarus.pointers.ss
View File

@ -5,7 +5,7 @@
pointer-ref-char pointer-ref-short pointer-ref-int pointer-ref-long
pointer-ref-uchar pointer-ref-ushort pointer-ref-uint pointer-ref-ulong
pointer-set-char pointer-set-short pointer-set-int pointer-set-long
ffi-prep-cif)
make-ffi make-callback)
(import
(except (ikarus)
pointer?
@ -138,22 +138,40 @@
[(double) 11]
[(pointer) 12]
[else (die who "invalid type" x)]))
(unless (list? argtypes)
(unless (list? argtypes)
(die who "arg types is not a list" argtypes))
(let ([argtypes-n (vector-map convert (list->vector argtypes))]
[rtype-n (convert rtype)])
(let ([cif (or (foreign-call "ikrt_ffi_prep_cif" rtype-n argtypes-n)
(die who "failed to initialize" rtype argtypes))])
(lambda (cfun)
(define data (vector cif cfun argtypes-n rtype-n))
(unless (pointer? cfun)
(die 'ffi "not a pointer" cfun))
(lambda args
(let ([argsvec (list->vector args)])
(unless (= (vector-length argsvec)
(vector-length argtypes-n))
(error 'ffi "args mismatch" argtypes args))
(foreign-call "ikrt_ffi_call" data argsvec)))))))
(values (or (foreign-call "ikrt_ffi_prep_cif" rtype-n argtypes-n)
(die who "failed to initialize" rtype argtypes))
argtypes-n
rtype-n)))
(define (make-ffi rtype argtypes)
(define who 'make-ffi)
(let-values ([(cif argtypes-n rtype-n)
(ffi-prep-cif rtype argtypes)])
(lambda (cfun)
(define data (vector cif cfun argtypes-n rtype-n))
(unless (pointer? cfun)
(die 'ffi "not a pointer" cfun))
(lambda args
(let ([argsvec (list->vector args)])
(unless (= (vector-length argsvec)
(vector-length argtypes-n))
(error 'ffi "args mismatch" argtypes args))
(foreign-call "ikrt_ffi_call" data argsvec))))))
(define (make-callback rtype argtypes)
(let-values ([(cif argtypes-n rtype-n)
(ffi-prep-cif rtype argtypes)])
(lambda (proc)
(define who 'make-callback)
(define data (vector cif proc argtypes-n rtype-n))
(unless (procedure? proc)
(die who "not a procedure"))
(or (foreign-call "ikrt_prepare_callback" data)
(die who "cannot prepare foreign callback")))))
)

2
scheme/last-revision
View File

@ -1 +1 @@
1599
1600

3
scheme/makefile.ss
View File

@ -1476,7 +1476,8 @@
[pointer-set-short $for]
[pointer-set-int $for]
[pointer-set-long $for]
[ffi-prep-cif $for]
[make-ffi $for]
[make-callback $for]
))

13
scheme/psyntax.expander.ss
View File

@ -181,16 +181,16 @@
[(and (memq sym (rib-sym* rib))
(find sym mark* sym* (rib-mark** rib) (rib-label* rib)))
=>
(lambda (p)
(lambda (p)
(unless (eq? label (car p))
(cond
[(top-level-context)
;;; override label
;;; XXX override label
(set-car! p label)]
[else
;;; signal an error if the identifier was already
;;; in the rib.
(stx-error id "cannot redefine")])))]
(stx-error id "multiple definitions of identifier")])))]
[else
(set-rib-sym*! rib (cons sym sym*))
(set-rib-mark**! rib (cons mark* (rib-mark** rib)))
@ -3121,8 +3121,8 @@
(library-import e))))
(vector-for-each
(lambda (id lab) (extend-rib! rib id lab))
id* lab*)))
(chi-body* (cdr e*) r mr lex* rhs* mod** kwd* exp* rib top?))
id* lab*))
(chi-body* (cdr e*) r mr lex* rhs* mod** kwd* exp* rib top?)))
(else
(if top?
(chi-body* (cdr e*) r mr
@ -3630,7 +3630,8 @@
(rtc (make-collector))
(vtc (make-collector)))
(let ((x
(parameterize ((inv-collector rtc)
(parameterize ((top-level-context #f)
(inv-collector rtc)
(vis-collector vtc)
(imp-collector itc))
(chi-expr x '() '()))))

5
src/ikarus-data.h
View File

@ -121,6 +121,10 @@ typedef struct ik_ptr_page{
ikptr ptr[ik_ptr_page_size];
} ik_ptr_page;
typedef struct callback_locative{
ikptr data;
struct callback_locative* next;
} callback_locative;
typedef struct ikpcb{
/* the first locations may be accessed by some */
@ -140,6 +144,7 @@ typedef struct ikpcb{
ikptr collect_key; /* offset = 48 */
/* the rest are not used by any scheme code */
/* they only support the runtime system (gc, etc.) */
callback_locative* callbacks;
ikptr* root0;
ikptr* root1;
unsigned int* segment_vector;

110
src/ikarus-ffi.c
View File

@ -17,6 +17,7 @@ alloc(size_t n, int m) {
return x;
}
static ffi_type*
scheme_to_ffi_type_cast(int n){
switch (n & 0xF) {
@ -104,22 +105,22 @@ ffi_to_scheme_value_cast(int n, void* p, ikpcb* pcb) {
ikptr
ikrt_ffi_prep_cif(ikptr rtptr, ikptr argstptr, ikpcb* pcb) {
ffi_cif* cif = alloc(sizeof(ffi_cif), 1);
bzero(cif, sizeof(ffi_cif));
ffi_abi abi = FFI_DEFAULT_ABI;
unsigned int nargs = unfix(ref(argstptr, off_vector_length));
ffi_type** argtypes = alloc(sizeof(ffi_type*), nargs);
ffi_type** argtypes = alloc(sizeof(ffi_type*), nargs+1);
int i;
for(i=0; i<nargs; i++){
ikptr argt = ref(argstptr, off_vector_data + i*wordsize);
argtypes[i] = scheme_to_ffi_type_cast(unfix(argt));
}
argtypes[nargs] = NULL;
ffi_type* rtype = scheme_to_ffi_type_cast(unfix(rtptr));
ffi_status s = ffi_prep_cif(cif, abi, nargs, rtype, argtypes);
if (s == FFI_OK) {
ikptr r = ik_safe_alloc(pcb, pointer_size);
ref(r, 0) = pointer_tag;
ref(r, wordsize) = (ikptr)cif;
return (r + vector_tag);
return r + vector_tag;
} else {
return false_object;
}
@ -136,13 +137,14 @@ ikrt_ffi_call(ikptr data, ikptr argsvec, ikpcb* pcb) {
ffi_cif* cif = (ffi_cif*) ref(cifptr, off_pointer_data);
void* fn = (void*) ref(funptr, off_pointer_data);
unsigned int n = unfix(ref(argsvec, off_vector_length));
void** avalues = alloc(sizeof(void*), n);
void** avalues = alloc(sizeof(void*), n+1);
int i;
for(i=0; i<n; i++){
ikptr t = ref(typevec, off_vector_data + i * wordsize);
ikptr v = ref(argsvec, off_vector_data + i * wordsize);
avalues[i] = scheme_to_ffi_value_cast(unfix(t), v);
}
avalues[n] = NULL;
void* rvalue = alloc_room_for_type(unfix(rtype));;
ffi_call(cif, fn, rvalue, avalues);
ikptr val = ffi_to_scheme_value_cast(unfix(rtype), rvalue, pcb);
@ -154,6 +156,101 @@ ikrt_ffi_call(ikptr data, ikptr argsvec, ikpcb* pcb) {
return val;
}
/*
ffi_status ffi_prep_cif (
ffi_cif *cif,
ffi_abi abi,
unsigned int nargs,
ffi_type *rtype,
ffi_type **argtypes)
void *ffi_closure_alloc (size_t size, void **code)
void ffi_closure_free (void *writable)
ffi_status ffi_prep_closure_loc (
ffi_closure *closure,
ffi_cif *cif,
void (*fun) (ffi_cif *cif, void *ret, void **args, void *user_data),
void *user_data,
void *codeloc)
*/
static void
generic_callback(ffi_cif *cif, void *ret, void **args, void *user_data){
/* convert args according to cif to scheme values */
/* call into scheme, get the return value */
/* convert the return value to C */
/* put the C return value in *ret */
/* done */
ikptr data = ((callback_locative*)user_data)->data;
ikptr proc = ref(data, off_vector_data + 1 * wordsize);
ikptr argtypes_conv = ref(data, off_vector_data + 2 * wordsize);
ikptr rtype_conv = ref(data, off_vector_data + 3 * wordsize);
fprintf(stderr, "in generic_callback\n");
exit(-1);
return;
}
ikptr
ikrt_prepare_callback(ikptr data, ikpcb* pcb){
ikptr cifptr = ref(data, off_vector_data + 0 * wordsize);
void* codeloc;
ffi_closure* closure = ffi_closure_alloc(sizeof(ffi_closure), &codeloc);
ffi_cif* cif = (ffi_cif*) ref(cifptr, off_pointer_data);
callback_locative* loc = malloc(sizeof(callback_locative));
if(!loc) {
fprintf(stderr, "ERROR: ikarus malloc error\n");
exit(-1);
}
ffi_status st =
ffi_prep_closure_loc(closure, cif, generic_callback, loc, codeloc);
if (st != FFI_OK) {
free(loc);
return false_object;
}
loc->data = data;
loc->next = pcb->callbacks;
pcb->callbacks = loc;
ikptr p = ik_safe_alloc(pcb, pointer_size);
ref(p, 0) = pointer_tag;
ref(p, wordsize) = (ikptr) codeloc;
return p+vector_tag;
}
int ho (int(*f)(int), int n) {
fprintf(stderr, "HO HO 0x%016lx!\n", (long)f);
int n0 = f(n);
fprintf(stderr, "GOT N0\n");
return n0 + f(n);
}
int ho2 (ikptr fptr, ikptr nptr) {
int (*f)(int) = (int(*)(int)) ref(fptr, off_pointer_data);
int n = unfix(nptr);
fprintf(stderr, "HO2 HO2 0x%016lx!\n", (long)f);
int n0 = f(n);
fprintf(stderr, "GOT N0\n");
return n0 + f(n);
}
int cadd1 (int n) {
return n+1;
}
void hello_world(int n) {
while(n > 0) {
fprintf(stderr, "Hello World\n");
@ -162,8 +259,9 @@ void hello_world(int n) {
}
#else
ikptr ikrt_ffi_prep_cif() { return false_object; }
ikrt_ffi_call() { return false_object; }
ikptr ikrt_ffi_prep_cif() { return false_object; }
ikrt_ffi_call() { return false_object; }
ikrt ikrt_prepare_callback() { return false_object; }
#endif