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

back into Scheme land.

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? 
@@ -142,18 +142,36 @@
       (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)
+      (values (or (foreign-call "ikrt_ffi_prep_cif" rtype-n argtypes-n)
-                     (die who "failed to initialize" rtype argtypes))])
+                  (die who "failed to initialize" rtype argtypes))
-        (lambda (cfun)
+              argtypes-n
-          (define data (vector cif cfun argtypes-n rtype-n))
+              rtype-n)))
-          (unless (pointer? cfun) 
+
-            (die 'ffi "not a pointer" cfun))
+  (define (make-ffi rtype argtypes)
-          (lambda args
+    (define who 'make-ffi)
-            (let ([argsvec (list->vector args)])
+    (let-values ([(cif argtypes-n rtype-n)
-              (unless (= (vector-length argsvec) 
+                  (ffi-prep-cif rtype argtypes)])
-                         (vector-length argtypes-n))
+      (lambda (cfun)
-                (error 'ffi "args mismatch" argtypes args))
+        (define data (vector cif cfun argtypes-n rtype-n))
-              (foreign-call "ikrt_ffi_call" data argsvec)))))))
+        (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")))))
 
   )
 

scheme/last-revision

@@ -1 +1 @@
-1599
+1600

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]
 
   ))
 

scheme/psyntax.expander.ss

@@ -185,12 +185,12 @@
              (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*)))
+                        id* lab*))
-                  (chi-body* (cdr e*) r mr lex* rhs* mod** kwd* exp* rib top?))
+                    (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 '() '()))))

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; 

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; 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; }
+ikptr ikrt_ffi_prep_cif()    { return false_object; }
-ikrt_ffi_call()           { return false_object; }
+ikrt_ffi_call()              { return false_object; }
+ikrt ikrt_prepare_callback() { return false_object; }
 #endif