2008-09-14 07:17:24 -04:00
|
|
|
|
|
|
|
#include "ikarus-data.h"
|
|
|
|
#include "config.h"
|
|
|
|
|
|
|
|
#if ENABLE_LIBFFI
|
|
|
|
#include <ffi.h>
|
|
|
|
#include <stdlib.h>
|
|
|
|
#include <strings.h>
|
|
|
|
|
2008-09-21 04:08:54 -04:00
|
|
|
#undef DEBUG_FFI
|
|
|
|
|
2008-09-14 07:17:24 -04:00
|
|
|
static void*
|
|
|
|
alloc(size_t n, int m) {
|
|
|
|
void* x = calloc(n, m);
|
|
|
|
if (x == NULL) {
|
|
|
|
fprintf(stderr, "ERROR (ikarus): calloc failed!\n");
|
|
|
|
exit(-1);
|
|
|
|
}
|
|
|
|
return x;
|
|
|
|
}
|
|
|
|
|
2008-09-26 02:46:07 -04:00
|
|
|
static ffi_type* scheme_to_ffi_type_cast(ikptr nptr);
|
2008-09-20 01:58:57 -04:00
|
|
|
|
2008-09-14 07:17:24 -04:00
|
|
|
static ffi_type*
|
2008-09-26 02:46:07 -04:00
|
|
|
scheme_to_ffi_record_type_cast(ikptr vec){
|
|
|
|
ikptr lenptr = ref(vec, -vector_tag);
|
|
|
|
if (! is_fixnum(lenptr)) {
|
|
|
|
fprintf(stderr, "NOT A VECTOR 0x%016lx\n", vec);
|
|
|
|
exit(-1);
|
|
|
|
}
|
|
|
|
long n = unfix(lenptr);
|
|
|
|
ffi_type* t = alloc(sizeof(ffi_type), 1);
|
|
|
|
ffi_type** ts = alloc(sizeof(ffi_type*), n+1);
|
|
|
|
t->size = 0;
|
|
|
|
t->alignment = 0;
|
|
|
|
t->type = FFI_TYPE_STRUCT;
|
|
|
|
t->elements = ts;
|
|
|
|
long i;
|
|
|
|
for(i=0; i<n; i++){
|
|
|
|
ts[i] = scheme_to_ffi_type_cast(ref(vec, off_vector_data + i*wordsize));
|
|
|
|
}
|
|
|
|
ts[n] = 0;
|
|
|
|
return t;
|
|
|
|
}
|
|
|
|
|
|
|
|
static ffi_type*
|
|
|
|
scheme_to_ffi_type_cast(ikptr nptr){
|
|
|
|
if (tagof(nptr) == vector_tag) {
|
|
|
|
return scheme_to_ffi_record_type_cast(nptr);
|
|
|
|
} else if (is_fixnum(nptr)) {
|
|
|
|
long n = unfix(nptr);
|
|
|
|
switch (n & 0xF) {
|
|
|
|
case 1: return &ffi_type_void;
|
|
|
|
case 2: return &ffi_type_uint8;
|
|
|
|
case 3: return &ffi_type_sint8;
|
|
|
|
case 4: return &ffi_type_uint16;
|
|
|
|
case 5: return &ffi_type_sint16;
|
|
|
|
case 6: return &ffi_type_uint32;
|
|
|
|
case 7: return &ffi_type_sint32;
|
|
|
|
case 8: return &ffi_type_uint64;
|
|
|
|
case 9: return &ffi_type_sint64;
|
|
|
|
case 10: return &ffi_type_float;
|
|
|
|
case 11: return &ffi_type_double;
|
|
|
|
case 12: return &ffi_type_pointer;
|
|
|
|
default:
|
|
|
|
fprintf(stderr, "INVALID ARG %ld", n);
|
|
|
|
exit(-1);
|
|
|
|
}
|
|
|
|
} else {
|
|
|
|
fprintf(stderr, "INVALID ARG %ld", nptr);
|
|
|
|
exit(-1);
|
2008-09-14 07:17:24 -04:00
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
static void*
|
2008-09-26 02:46:07 -04:00
|
|
|
alloc_room_for_type(ffi_type* t){
|
2008-09-14 07:17:24 -04:00
|
|
|
return alloc(t->size, 1);
|
|
|
|
}
|
|
|
|
|
|
|
|
extern long extract_num(ikptr x);
|
|
|
|
|
2008-09-26 02:46:07 -04:00
|
|
|
static void scheme_to_ffi_value_cast(ffi_type*, ikptr, ikptr, void*);
|
|
|
|
|
2008-09-23 03:21:41 -04:00
|
|
|
static void
|
2008-09-26 02:46:07 -04:00
|
|
|
scheme_to_ffi_record_value_cast(ffi_type* t, ikptr nptr, ikptr p, void* r) {
|
|
|
|
if (t->type != FFI_TYPE_STRUCT) {
|
|
|
|
fprintf(stderr, "not a struct type\n");
|
|
|
|
exit(-1);
|
|
|
|
}
|
|
|
|
ffi_type** ts = t->elements;
|
|
|
|
char* buf = r;
|
|
|
|
ikptr lenptr = ref(nptr, off_vector_length);
|
|
|
|
int n = unfix(lenptr);
|
|
|
|
int i;
|
|
|
|
for(i=0; i<n; i++) {
|
|
|
|
ffi_type* at = ts[i];
|
|
|
|
ikptr argt = ref(nptr, off_vector_data + i*wordsize);
|
|
|
|
ikptr arg = ref(p, off_vector_data + i*wordsize);
|
|
|
|
scheme_to_ffi_value_cast(at, argt, arg, buf);
|
|
|
|
buf += at->size;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
static void
|
|
|
|
scheme_to_ffi_value_cast(ffi_type* t, ikptr nptr, ikptr p, void* r) {
|
|
|
|
if (tagof(nptr) == vector_tag) {
|
|
|
|
scheme_to_ffi_record_value_cast(t, nptr, p, r);
|
|
|
|
} else if (is_fixnum(nptr)) {
|
|
|
|
long n = unfix(nptr);
|
|
|
|
switch (n & 0xF) {
|
|
|
|
case 1: { return; }
|
|
|
|
case 2: // ffi_type_uint8;
|
|
|
|
case 3:
|
|
|
|
{ *((char*)r) = extract_num(p); return; }
|
|
|
|
case 4: // ffi_type_uint16;
|
|
|
|
case 5:
|
|
|
|
{ *((short*)r) = extract_num(p); return; }
|
|
|
|
case 6: // ffi_type_uint32;
|
|
|
|
case 7:
|
|
|
|
{ *((int*)r) = extract_num(p); return; }
|
|
|
|
case 8: // ffi_type_uint64;
|
|
|
|
case 9:
|
|
|
|
{ *((long*)r) = extract_num(p); return; }
|
|
|
|
case 10: //return &ffi_type_float;
|
|
|
|
{ *((float*)r) = flonum_data(p); return; }
|
|
|
|
case 11: //return &ffi_type_double;
|
|
|
|
{ *((double*)r) = flonum_data(p); return; }
|
|
|
|
case 12: //return &ffi_type_pointer;
|
|
|
|
{ *((void**)r) = (void*)ref(p, off_pointer_data); return; }
|
|
|
|
default:
|
|
|
|
fprintf(stderr, "INVALID ARG %ld", n);
|
|
|
|
exit(-1);
|
|
|
|
}
|
|
|
|
} else {
|
|
|
|
fprintf(stderr, "INVALID TYPE 0x%016lx\n", nptr);
|
|
|
|
exit(-1);
|
2008-09-14 07:17:24 -04:00
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
extern ikptr u_to_number(unsigned long x, ikpcb* pcb);
|
|
|
|
extern ikptr s_to_number(signed long x, ikpcb* pcb);
|
|
|
|
extern ikptr d_to_number(double x, ikpcb* pcb);
|
|
|
|
extern ikptr make_pointer(void* x, ikpcb* pcb);
|
|
|
|
static ikptr
|
|
|
|
ffi_to_scheme_value_cast(int n, void* p, ikpcb* pcb) {
|
|
|
|
switch (n & 0xF) {
|
|
|
|
case 1: return void_object;
|
|
|
|
case 2: return u_to_number(*((unsigned char*)p), pcb);
|
|
|
|
case 3: return s_to_number(*((signed char*)p), pcb);
|
|
|
|
case 4: return u_to_number(*((unsigned short*)p), pcb);
|
|
|
|
case 5: return s_to_number(*((signed short*)p), pcb);
|
|
|
|
case 6: return u_to_number(*((unsigned int*)p), pcb);
|
|
|
|
case 7: return s_to_number(*((signed int*)p), pcb);
|
|
|
|
case 8: return u_to_number(*((unsigned long*)p), pcb);
|
|
|
|
case 9: return s_to_number(*((signed long*)p), pcb);
|
|
|
|
case 10: return d_to_number(*((float*)p), pcb);
|
|
|
|
case 11: return d_to_number(*((double*)p), pcb);
|
|
|
|
case 12: return make_pointer(*((void**)p), pcb);
|
|
|
|
default:
|
|
|
|
fprintf(stderr, "INVALID ARG %d", n);
|
|
|
|
exit(-1);
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
ikptr
|
|
|
|
ikrt_ffi_prep_cif(ikptr rtptr, ikptr argstptr, ikpcb* pcb) {
|
|
|
|
ffi_cif* cif = alloc(sizeof(ffi_cif), 1);
|
|
|
|
ffi_abi abi = FFI_DEFAULT_ABI;
|
|
|
|
unsigned int nargs = unfix(ref(argstptr, off_vector_length));
|
2008-09-20 01:58:57 -04:00
|
|
|
ffi_type** argtypes = alloc(sizeof(ffi_type*), nargs+1);
|
2008-09-14 07:17:24 -04:00
|
|
|
int i;
|
|
|
|
for(i=0; i<nargs; i++){
|
|
|
|
ikptr argt = ref(argstptr, off_vector_data + i*wordsize);
|
2008-09-26 02:46:07 -04:00
|
|
|
argtypes[i] = scheme_to_ffi_type_cast(argt);
|
2008-09-14 07:17:24 -04:00
|
|
|
}
|
2008-09-20 01:58:57 -04:00
|
|
|
argtypes[nargs] = NULL;
|
2008-09-26 02:46:07 -04:00
|
|
|
ffi_type* rtype = scheme_to_ffi_type_cast(rtptr);
|
2008-09-14 07:17:24 -04:00
|
|
|
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;
|
2008-09-20 01:58:57 -04:00
|
|
|
return r + vector_tag;
|
2008-09-14 07:17:24 -04:00
|
|
|
} else {
|
|
|
|
return false_object;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2008-09-21 04:08:54 -04:00
|
|
|
|
|
|
|
|
2008-09-23 00:24:41 -04:00
|
|
|
static void
|
|
|
|
dump_stack(ikpcb* pcb, char* msg) {
|
|
|
|
fprintf(stderr, "==================== %s\n", msg);
|
|
|
|
ikptr frame_base = pcb->frame_base;
|
|
|
|
ikptr frame_pointer = pcb->frame_pointer;
|
|
|
|
ikptr p = frame_pointer;
|
|
|
|
fprintf(stderr, "fp=0x%016lx base=0x%016lx\n", frame_pointer, frame_base);
|
|
|
|
while(p < frame_base) {
|
|
|
|
fprintf(stderr, "*0x%016lx = 0x%016lx\n", p, ref(p, 0));
|
|
|
|
p += wordsize;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2008-09-21 04:08:54 -04:00
|
|
|
|
2008-09-23 00:24:41 -04:00
|
|
|
/* FIXME: handle stack overflow */
|
2008-09-21 04:08:54 -04:00
|
|
|
ikptr
|
|
|
|
ikrt_seal_scheme_stack(ikpcb* pcb) {
|
|
|
|
#if 0
|
|
|
|
| |
|
|
|
|
| |
|
|
|
|
| |
|
|
|
|
| |
|
|
|
|
+--------------+
|
|
|
|
| underflow | <--------- new frame pointer
|
|
|
|
+--------------+
|
|
|
|
| return point | <--------- old frame pointer, new frame base
|
|
|
|
+--------------+
|
|
|
|
| . |
|
|
|
|
| . |
|
|
|
|
| . |
|
|
|
|
| |
|
|
|
|
+--------------+
|
|
|
|
| underflow | <--------- old frame base
|
|
|
|
+--------------+
|
|
|
|
#endif
|
|
|
|
ikptr frame_base = pcb->frame_base;
|
|
|
|
ikptr frame_pointer = pcb->frame_pointer;
|
|
|
|
#ifdef DEBUG_FFI
|
2008-09-23 00:24:41 -04:00
|
|
|
dump_stack(pcb, "BEFORE SEALING");
|
2008-09-21 04:08:54 -04:00
|
|
|
fprintf(stderr, "old base=0x%016lx fp=0x%016lx\n", pcb->frame_base,
|
|
|
|
pcb->frame_pointer);
|
|
|
|
#endif
|
|
|
|
if ((frame_base - wordsize) != frame_pointer) {
|
|
|
|
ikptr underflow_handler = ref(frame_base, -wordsize);
|
|
|
|
cont* k = (cont*) pcb->next_k;
|
|
|
|
cont* nk = (cont*) ik_unsafe_alloc(pcb, sizeof(cont));
|
2008-09-23 00:24:41 -04:00
|
|
|
nk->tag = continuation_tag;
|
2008-09-21 04:08:54 -04:00
|
|
|
nk->next = (ikptr) k;
|
|
|
|
nk->top = frame_pointer;
|
|
|
|
#ifdef DEBUG_FFI
|
|
|
|
fprintf(stderr, "rp=0x%016lx\n",
|
|
|
|
ref(frame_pointer, 0));
|
|
|
|
#endif
|
|
|
|
nk->size = frame_base - frame_pointer - wordsize;
|
|
|
|
#ifdef DEBUG_FFI
|
|
|
|
fprintf(stderr, "frame size=%ld\n", nk->size);
|
|
|
|
#endif
|
|
|
|
pcb->next_k = vector_tag + (ikptr)nk;
|
|
|
|
pcb->frame_base = frame_pointer;
|
2008-09-23 00:24:41 -04:00
|
|
|
pcb->frame_pointer = pcb->frame_base - wordsize;
|
2008-09-21 04:08:54 -04:00
|
|
|
#ifdef DEBUG_FFI
|
|
|
|
fprintf(stderr, "new base=0x%016lx fp=0x%016lx\n", pcb->frame_base,
|
|
|
|
pcb->frame_pointer);
|
|
|
|
fprintf(stderr, "uf=0x%016lx\n", underflow_handler);
|
|
|
|
#endif
|
|
|
|
ref(pcb->frame_pointer, 0) = underflow_handler;
|
|
|
|
} else {
|
|
|
|
#ifdef DEBUG_FFI
|
|
|
|
fprintf(stderr, "already sealed\n");
|
|
|
|
#endif
|
|
|
|
}
|
2008-09-23 00:24:41 -04:00
|
|
|
#ifdef DEBUG_FFI
|
|
|
|
dump_stack(pcb, "AFTER SEALING");
|
|
|
|
#endif
|
2008-09-21 04:08:54 -04:00
|
|
|
return void_object;
|
|
|
|
}
|
|
|
|
|
|
|
|
ikptr
|
|
|
|
ikrt_call_back(ikptr proc, ikpcb* pcb) {
|
|
|
|
ikrt_seal_scheme_stack(pcb);
|
2008-09-23 00:24:41 -04:00
|
|
|
|
2008-09-23 01:49:06 -04:00
|
|
|
ikptr sk = ik_unsafe_alloc(pcb, system_continuation_size);
|
|
|
|
ref(sk, 0) = system_continuation_tag;
|
|
|
|
ref(sk, disp_system_continuation_top) = pcb->system_stack;
|
|
|
|
ref(sk, disp_system_continuation_next) = pcb->next_k;
|
|
|
|
pcb->next_k = sk + vector_tag;
|
2008-09-21 04:08:54 -04:00
|
|
|
ikptr entry_point = ref(proc, off_closure_code);
|
|
|
|
#ifdef DEBUG_FFI
|
|
|
|
fprintf(stderr, "system_stack = 0x%016lx\n", pcb->system_stack);
|
|
|
|
#endif
|
|
|
|
ikptr code_ptr = entry_point - off_code_data;
|
2008-09-23 00:24:41 -04:00
|
|
|
pcb->frame_pointer = pcb->frame_base;
|
2008-09-21 04:08:54 -04:00
|
|
|
ikptr rv = ik_exec_code(pcb, code_ptr, 0, proc);
|
|
|
|
#ifdef DEBUG_FFI
|
|
|
|
fprintf(stderr, "system_stack = 0x%016lx\n", pcb->system_stack);
|
|
|
|
#endif
|
|
|
|
#ifdef DEBUG_FFI
|
2008-09-23 00:24:41 -04:00
|
|
|
fprintf(stderr, "rv=0x%016lx\n", rv);
|
2008-09-21 04:08:54 -04:00
|
|
|
#endif
|
2008-09-23 01:49:06 -04:00
|
|
|
sk = pcb->next_k - vector_tag;
|
|
|
|
if (ref(sk, 0) != system_continuation_tag) {
|
|
|
|
fprintf(stderr, "ikarus internal error: invalid system cont\n");
|
|
|
|
exit(-1);
|
|
|
|
}
|
|
|
|
pcb->next_k = ref(sk, disp_system_continuation_next);
|
|
|
|
ref(sk, disp_system_continuation_next) = pcb->next_k;
|
|
|
|
pcb->system_stack = ref(sk, disp_system_continuation_top);
|
2008-09-21 04:08:54 -04:00
|
|
|
pcb->frame_pointer = pcb->frame_base - wordsize;
|
|
|
|
#ifdef DEBUG_FFI
|
|
|
|
fprintf(stderr, "rp=0x%016lx\n", ref(pcb->frame_pointer, 0));
|
|
|
|
#endif
|
2008-09-23 00:24:41 -04:00
|
|
|
return rv;
|
2008-09-21 04:08:54 -04:00
|
|
|
}
|
|
|
|
|
2008-09-14 07:17:24 -04:00
|
|
|
|
|
|
|
|
|
|
|
ikptr
|
|
|
|
ikrt_ffi_call(ikptr data, ikptr argsvec, ikpcb* pcb) {
|
2008-09-21 04:08:54 -04:00
|
|
|
|
|
|
|
ikrt_seal_scheme_stack(pcb);
|
2008-09-23 01:49:06 -04:00
|
|
|
ikptr sk = ik_unsafe_alloc(pcb, system_continuation_size);
|
|
|
|
ref(sk, 0) = system_continuation_tag;
|
|
|
|
ref(sk, disp_system_continuation_top) = pcb->system_stack;
|
|
|
|
ref(sk, disp_system_continuation_next) = pcb->next_k;
|
|
|
|
pcb->next_k = sk + vector_tag;
|
|
|
|
|
2008-09-21 04:08:54 -04:00
|
|
|
|
2008-09-14 07:17:24 -04:00
|
|
|
ikptr cifptr = ref(data, off_vector_data + 0 * wordsize);
|
|
|
|
ikptr funptr = ref(data, off_vector_data + 1 * wordsize);
|
|
|
|
ikptr typevec = ref(data, off_vector_data + 2 * wordsize);
|
|
|
|
ikptr rtype = ref(data, off_vector_data + 3 * wordsize);
|
|
|
|
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));
|
2008-09-20 01:58:57 -04:00
|
|
|
void** avalues = alloc(sizeof(void*), n+1);
|
2008-09-14 07:17:24 -04:00
|
|
|
int i;
|
|
|
|
for(i=0; i<n; i++){
|
2008-09-26 02:46:07 -04:00
|
|
|
ffi_type* t = cif->arg_types[i];
|
|
|
|
ikptr at = ref(typevec, off_vector_data + i * wordsize);
|
2008-09-14 07:17:24 -04:00
|
|
|
ikptr v = ref(argsvec, off_vector_data + i * wordsize);
|
2008-09-26 02:46:07 -04:00
|
|
|
void* p = alloc_room_for_type(t);
|
2008-09-23 03:21:41 -04:00
|
|
|
avalues[i] = p;
|
2008-09-26 02:46:07 -04:00
|
|
|
scheme_to_ffi_value_cast(t, at, v, p);
|
2008-09-14 07:17:24 -04:00
|
|
|
}
|
2008-09-20 01:58:57 -04:00
|
|
|
avalues[n] = NULL;
|
2008-09-26 02:46:07 -04:00
|
|
|
void* rvalue = alloc_room_for_type(cif->rtype);
|
2008-09-14 07:17:24 -04:00
|
|
|
ffi_call(cif, fn, rvalue, avalues);
|
|
|
|
ikptr val = ffi_to_scheme_value_cast(unfix(rtype), rvalue, pcb);
|
|
|
|
for(i=0; i<n; i++){
|
|
|
|
free(avalues[i]);
|
|
|
|
}
|
2008-09-21 04:08:54 -04:00
|
|
|
#ifdef DEBUG_FFI
|
2008-09-23 00:24:41 -04:00
|
|
|
fprintf(stderr, "DONE WITH CALL, RV=0x%016lx\n", (long)val);
|
2008-09-21 04:08:54 -04:00
|
|
|
#endif
|
2008-09-14 07:17:24 -04:00
|
|
|
free(avalues);
|
|
|
|
free(rvalue);
|
2008-09-23 01:49:06 -04:00
|
|
|
|
2008-09-23 00:24:41 -04:00
|
|
|
pcb->frame_pointer = pcb->frame_base - wordsize;
|
2008-09-23 01:49:06 -04:00
|
|
|
|
|
|
|
sk = pcb->next_k - vector_tag;
|
|
|
|
if (ref(sk, 0) != system_continuation_tag) {
|
|
|
|
fprintf(stderr, "ikarus internal error: invalid system cont\n");
|
|
|
|
exit(-1);
|
|
|
|
}
|
|
|
|
pcb->next_k = ref(sk, disp_system_continuation_next);
|
|
|
|
pcb->system_stack = ref(sk, disp_system_continuation_top);
|
|
|
|
|
2008-09-14 07:17:24 -04:00
|
|
|
return val;
|
|
|
|
}
|
|
|
|
|
2008-09-20 01:58:57 -04:00
|
|
|
|
|
|
|
/*
|
|
|
|
|
|
|
|
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)
|
|
|
|
|
|
|
|
*/
|
|
|
|
|
2008-09-21 04:08:54 -04:00
|
|
|
extern ikpcb* the_pcb;
|
2008-09-20 01:58:57 -04:00
|
|
|
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);
|
2008-09-23 03:21:41 -04:00
|
|
|
ikptr n = unfix(ref(argtypes_conv, off_vector_length));
|
2008-09-20 01:58:57 -04:00
|
|
|
|
2008-09-21 04:08:54 -04:00
|
|
|
ikpcb* pcb = the_pcb;
|
|
|
|
ikptr code_entry = ref(proc, off_closure_code);
|
|
|
|
ikptr code_ptr = code_entry - off_code_data;
|
2008-09-23 01:49:06 -04:00
|
|
|
|
2008-09-23 00:24:41 -04:00
|
|
|
pcb->frame_pointer = pcb->frame_base;
|
2008-09-23 03:21:41 -04:00
|
|
|
int i;
|
|
|
|
for(i = 0; i < n; i++){
|
|
|
|
ikptr argt = ref(argtypes_conv, off_vector_data + i*wordsize);
|
|
|
|
void* argp = args[i];
|
|
|
|
ref(pcb->frame_pointer, -2*wordsize - i*wordsize) =
|
|
|
|
ffi_to_scheme_value_cast(unfix(argt), argp, pcb);
|
|
|
|
}
|
|
|
|
ikptr rv = ik_exec_code(pcb, code_ptr, fix(-n), proc);
|
2008-09-21 04:08:54 -04:00
|
|
|
#ifdef DEBUG_FFI
|
2008-09-23 00:24:41 -04:00
|
|
|
fprintf(stderr, "and back with rv=0x%016lx!\n", rv);
|
2008-09-21 04:08:54 -04:00
|
|
|
#endif
|
2008-09-26 02:46:07 -04:00
|
|
|
scheme_to_ffi_value_cast(cif->rtype, rtype_conv, rv, ret);
|
2008-09-20 01:58:57 -04:00
|
|
|
return;
|
|
|
|
}
|
|
|
|
|
|
|
|
ikptr
|
|
|
|
ikrt_prepare_callback(ikptr data, ikpcb* pcb){
|
2008-09-22 21:55:05 -04:00
|
|
|
#if FFI_CLOSURES
|
2008-09-20 01:58:57 -04:00
|
|
|
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;
|
2008-09-22 21:55:05 -04:00
|
|
|
#else
|
|
|
|
return false_object
|
|
|
|
#endif
|
2008-09-20 01:58:57 -04:00
|
|
|
}
|
|
|
|
|
|
|
|
int ho (int(*f)(int), int n) {
|
2008-09-21 04:08:54 -04:00
|
|
|
// fprintf(stderr, "HO HO 0x%016lx!\n", (long)f);
|
2008-09-20 01:58:57 -04:00
|
|
|
int n0 = f(n);
|
2008-09-21 04:08:54 -04:00
|
|
|
// fprintf(stderr, "GOT N0\n");
|
2008-09-20 01:58:57 -04:00
|
|
|
return n0 + f(n);
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
int ho2 (ikptr fptr, ikptr nptr) {
|
|
|
|
int (*f)(int) = (int(*)(int)) ref(fptr, off_pointer_data);
|
|
|
|
int n = unfix(nptr);
|
2008-09-21 04:08:54 -04:00
|
|
|
// fprintf(stderr, "HO2 HO2 0x%016lx!\n", (long)f);
|
2008-09-20 01:58:57 -04:00
|
|
|
int n0 = f(n);
|
2008-09-21 04:08:54 -04:00
|
|
|
// fprintf(stderr, "GOT N0\n");
|
2008-09-20 01:58:57 -04:00
|
|
|
return n0 + f(n);
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2008-09-23 03:21:41 -04:00
|
|
|
int test_I_I (int(*f)(int), int n0) {
|
|
|
|
return f(n0);
|
|
|
|
}
|
|
|
|
|
|
|
|
int test_I_II (int(*f)(int,int), int n0, int n1) {
|
|
|
|
return f(n0,n1);
|
|
|
|
}
|
|
|
|
|
|
|
|
int test_I_III (int(*f)(int,int,int), int n0, int n1, int n2) {
|
|
|
|
return f(n0,n1,n2);
|
|
|
|
}
|
|
|
|
|
|
|
|
int add_I_I(int n0) {
|
|
|
|
return n0;
|
|
|
|
}
|
|
|
|
int add_I_II(int n0, int n1) {
|
|
|
|
return n0+n1;
|
|
|
|
}
|
|
|
|
int add_I_III(int n0, int n1, int n2) {
|
|
|
|
return n0+n1+n2;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
|
2008-09-26 02:46:07 -04:00
|
|
|
struct Point{
|
|
|
|
float x;
|
|
|
|
float y;
|
|
|
|
};
|
|
|
|
|
|
|
|
struct Rect{
|
|
|
|
struct Point tl;
|
|
|
|
struct Point br;
|
|
|
|
};
|
|
|
|
|
|
|
|
float test_area_F_R(struct Rect r) {
|
|
|
|
float dx = r.br.x - r.tl.x;
|
|
|
|
float dy = r.br.y - r.tl.y;
|
|
|
|
return dx * dy;
|
|
|
|
}
|
2008-09-23 03:21:41 -04:00
|
|
|
|
|
|
|
double test_D_D (double(*f)(double), double n0) {
|
|
|
|
return f(n0);
|
|
|
|
}
|
|
|
|
|
|
|
|
double test_D_DD (double(*f)(double,double), double n0, double n1) {
|
|
|
|
return f(n0,n1);
|
|
|
|
}
|
|
|
|
|
|
|
|
double test_D_DDD (double(*f)(double,double,double), double n0, double n1, double n2) {
|
|
|
|
return f(n0,n1,n2);
|
|
|
|
}
|
|
|
|
|
|
|
|
double add_D_D(double n0) {
|
|
|
|
return n0;
|
|
|
|
}
|
|
|
|
double add_D_DD(double n0, double n1) {
|
|
|
|
return n0+n1;
|
|
|
|
}
|
|
|
|
double add_D_DDD(double n0, double n1, double n2) {
|
|
|
|
return n0+n1+n2;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
|
2008-09-20 01:58:57 -04:00
|
|
|
|
|
|
|
|
|
|
|
int cadd1 (int n) {
|
|
|
|
return n+1;
|
|
|
|
}
|
|
|
|
|
2008-09-14 07:17:24 -04:00
|
|
|
void hello_world(int n) {
|
|
|
|
while(n > 0) {
|
|
|
|
fprintf(stderr, "Hello World\n");
|
|
|
|
n--;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
#else
|
2008-09-20 01:58:57 -04:00
|
|
|
ikptr ikrt_ffi_prep_cif() { return false_object; }
|
2008-09-21 04:08:54 -04:00
|
|
|
ikptr ikrt_ffi_call() { return false_object; }
|
|
|
|
ikptr ikrt_prepare_callback() { return false_object; }
|
2008-09-14 07:17:24 -04:00
|
|
|
#endif
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|