From 06fd988a17b52e1a19f9d310e6295b9b86fbc89b Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Sat, 20 Sep 2008 01:58:57 -0400 Subject: [PATCH] C callbacks now reach the C point where they should make the call back into Scheme land. --- scheme/ikarus.pointers.ss | 46 +++++++++++----- scheme/last-revision | 2 +- scheme/makefile.ss | 3 +- scheme/psyntax.expander.ss | 13 +++-- src/ikarus-data.h | 5 ++ src/ikarus-ffi.c | 110 +++++++++++++++++++++++++++++++++++-- 6 files changed, 151 insertions(+), 28 deletions(-) diff --git a/scheme/ikarus.pointers.ss b/scheme/ikarus.pointers.ss index 47ceee5..70a4181 100644 --- a/scheme/ikarus.pointers.ss +++ b/scheme/ikarus.pointers.ss @@ -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"))))) ) diff --git a/scheme/last-revision b/scheme/last-revision index bf90791..b67470f 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1599 +1600 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index c4e7100..b2a4bea 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -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] )) diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss index 90f6cfd..875cb75 100644 --- a/scheme/psyntax.expander.ss +++ b/scheme/psyntax.expander.ss @@ -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 '() '())))) diff --git a/src/ikarus-data.h b/src/ikarus-data.h index 8b5b6b2..f075855 100644 --- a/src/ikarus-data.h +++ b/src/ikarus-data.h @@ -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; diff --git a/src/ikarus-ffi.c b/src/ikarus-ffi.c index 7c7291d..34a9cd3 100644 --- a/src/ikarus-ffi.c +++ b/src/ikarus-ffi.c @@ -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; idata; + 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