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

ffi callbacks sorta kinda work now.

This commit is contained in:
Abdulaziz Ghuloum 2008-09-21 04:08:54 -04:00
parent 06fd988a17
commit e07d8f9760
11 changed files with 224 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
c32
View File

@ -1,6 +1,10 @@
#!/usr/bin/env sh #!/usr/bin/env sh
./configure --prefix=/Users/ikarus/.opt CFLAGS=-m32 LDFLAGS=-m32 \ ./configure \
--enable-libffi \
--prefix=/Users/ikarus/.opt \
CFLAGS="-m32 -I$HOME/.opt/lib/libffi-3.0.6/include" \
LDFLAGS="-m32 -L$HOME/.opt/lib" \
&& make clean \ && make clean \
&& make && make

37
lab/test-ffi.ss Normal file
View File

@ -0,0 +1,37 @@
(import (ikarus) (ikarus system $foreign))
(define self (dlopen #f))
(define hosym (dlsym self "ho"))
(define ho
((make-ffi 'sint32 '(pointer sint32)) hosym))
(define foradd1
((make-callback 'sint32 '(sint32))
(trace-lambda add1 (n)
(add1 n))))
(define foradd1^
((make-callback 'sint32 '(sint32))
(lambda (n)
(add1 n))))
(define-syntax assert^
(syntax-rules ()
[(_ expr)
(begin
(line)
(printf "TESTING ~s\n" 'expr)
(assert expr)
(printf "OK\n"))]))
(define (line)
(printf "=========================================================\n"))
(assert^ (= (ho (dlsym self "cadd1") 17) (+ 18 18)))
(assert^ (= (ho foradd1^ 17) (+ 18 18)))
(assert^ (= (ho foradd1 17) (+ 18 18)))
(line)
(printf "Happy Happy Joy Joy\n")

4
scheme/ikarus.pointers.ss
View File

@ -160,7 +160,9 @@
(unless (= (vector-length argsvec) (unless (= (vector-length argsvec)
(vector-length argtypes-n)) (vector-length argtypes-n))
(error 'ffi "args mismatch" argtypes args)) (error 'ffi "args mismatch" argtypes args))
(foreign-call "ikrt_ffi_call" data argsvec)))))) (call/cc
(lambda (k)
(foreign-call "ikrt_ffi_call" data argsvec))))))))
(define (make-callback rtype argtypes) (define (make-callback rtype argtypes)
(let-values ([(cif argtypes-n rtype-n) (let-values ([(cif argtypes-n rtype-n)

2
scheme/last-revision
View File

@ -1 +1 @@
1600 1601

3
scheme/pass-specify-rep-primops.ss
View File

@ -2354,7 +2354,8 @@
[(P) [(P)
(prm '= (prm 'int+ (prm '= (prm 'int+
(prm 'mref pcr (K pcb-frame-base)) (prm 'mref pcr (K pcb-frame-base))
(K (- wordsize))) fpr)]) (K (- wordsize)))
fpr)])
(define-primop $current-frame unsafe (define-primop $current-frame unsafe
[(V) (prm 'mref pcr (K pcb-next-continuation))]) [(V) (prm 'mref pcr (K pcb-next-continuation))])

14
src/ikarus-data.h
View File

@ -174,6 +174,16 @@ typedef struct ikpcb{
struct timeval collect_rtime; struct timeval collect_rtime;
} ikpcb; } ikpcb;
typedef struct {
ikptr tag;
ikptr top;
long int size;
ikptr next;
} cont;
ikpcb* ik_collect(unsigned long int, ikpcb*); ikpcb* ik_collect(unsigned long int, ikpcb*);
void ikarus_usage_short(void); void ikarus_usage_short(void);
@ -195,7 +205,7 @@ void ik_free_symbol_table(ikpcb* pcb);
void ik_fasl_load(ikpcb* pcb, char* filename); void ik_fasl_load(ikpcb* pcb, char* filename);
void ik_relocate_code(ikptr); void ik_relocate_code(ikptr);
ikptr ik_exec_code(ikpcb* pcb, ikptr code_ptr); ikptr ik_exec_code(ikpcb* pcb, ikptr code_ptr, ikptr argcount, ikptr cp);
void ik_print(ikptr x); void ik_print(ikptr x);
void ik_fprint(FILE*, ikptr x); void ik_fprint(FILE*, ikptr x);
@ -204,7 +214,7 @@ ikptr ikrt_strings_to_gensym(ikptr, ikptr, ikpcb*);
ikptr ik_cstring_to_symbol(char*, ikpcb*); ikptr ik_cstring_to_symbol(char*, ikpcb*);
ikptr ik_asm_enter(ikpcb*, ikptr code_object, ikptr arg); ikptr ik_asm_enter(ikpcb*, ikptr code_object, ikptr arg, ikptr cp);
ikptr ik_asm_reenter(ikpcb*, ikptr code_object, ikptr val); ikptr ik_asm_reenter(ikpcb*, ikptr code_object, ikptr val);
ikptr ik_underflow_handler(ikpcb*); ikptr ik_underflow_handler(ikpcb*);
ikptr ik_unsafe_alloc(ikpcb* pcb, int size); ikptr ik_unsafe_alloc(ikpcb* pcb, int size);

38
src/ikarus-enter.S
View File

@ -47,32 +47,31 @@ _ik_asm_enter:
mov %r14, -40(%rsp) # preserve mov %r14, -40(%rsp) # preserve
mov %r15, -48(%rsp) # preserve mov %r15, -48(%rsp) # preserve
# closure pointer is the 4th arg, or %rcx
# argcount is the third arg, or %rdx
# code is the second arg, or %rsi # code is the second arg, or %rsi
# pcb is the first arg, or %rdi # pcb is the first arg, or %rdi
# return point is at 0(%rsp) # return point is at 0(%rsp)
mov %rsi, %rax # move code pointer to %rax mov %rdx, %rax # set up arg count
mov %rsi, %rdx # move code pointer to %rdx
mov %rdi, %rsi # move pcb into pcb-register (%rsi) mov %rdi, %rsi # move pcb into pcb-register (%rsi)
mov %rcx, %rdi # move closure pointer into cpr
mov 0(%rsi), %rbp # allocation pointer is at 0(pcb) mov 0(%rsi), %rbp # allocation pointer is at 0(pcb)
sub $64, %rsp # 64 for alignment sub $64, %rsp # 64 for alignment
mov %rsp, 48(%rsi) # save esp in pcb->system_stack mov %rsp, 48(%rsi) # save esp in pcb->system_stack
mov 16(%rsi), %rsp # load scheme stack from pcb->frame_pinter mov 16(%rsi), %rsp # load scheme stack from pcb->frame_pinter
jmp L_call jmp L_call
.byte 0 .quad 8
.byte 0 .quad 0
.byte 0
.byte 0
.byte 0
.byte 0
.byte 0
.byte 0
L_multivalue_label: # FIXME L_multivalue_label: # FIXME
.quad L_multivalue_underflow .quad L_multivalue_underflow
.quad 0 .quad 0
L_call: L_call:
call *%rax # goooooooo call *%rdx # goooooooo
# now we're back # now we're back
ik_underflow_handler: ik_underflow_handler:
_ik_underflow_handler:
mov %rax, -16(%rsp) # store the return value mov %rax, -16(%rsp) # store the return value
mov $-8, %rax # set rvcount = 1 mov $-8, %rax # set rvcount = 1
L_do_underflow: L_do_underflow:
@ -209,32 +208,29 @@ L_back:
.align 8 .align 8
ik_asm_enter: ik_asm_enter:
_ik_asm_enter: _ik_asm_enter:
# ignored value is the third arg 12(%esp) # closure pointer is the 4th arg, 16(%esp)
# argcount is the third arg, or 12(%esp)
# code is the second arg 8(%esp) # code is the second arg 8(%esp)
# pcb is the first arg 4(%esp) # pcb is the first arg 4(%esp)
# return point is at 0(%esp) # return point is at 0(%esp)
movl 12(%esp), %eax # arg count
movl 16(%esp), %edi # closure pointer
movl %esi, -4(%esp) # preserve movl %esi, -4(%esp) # preserve
movl %ebp, -8(%esp) # preserve movl %ebp, -8(%esp) # preserve
movl 4(%esp), %esi movl 4(%esp), %esi
movl 0(%esi), %ebp # allocation pointer is at 0(pcb) movl 0(%esi), %ebp # allocation pointer is at 0(pcb)
movl %esp, %eax movl %esp, %ecx
subl $16, %esp # 24 for alignment subl $16, %esp # 24 for alignment
movl %esp, 24(%esi) # save esp in pcb->system_stack movl %esp, 24(%esi) # save esp in pcb->system_stack
movl 8(%esi), %esp # load scheme stack from pcb->frame_pinter movl 8(%esi), %esp # load scheme stack from pcb->frame_pinter
jmp L_call jmp L_call
.byte 0 .long 4
.byte 0 .long 0
.byte 0
.byte 0
.byte 0
.byte 0
.byte 0
.byte 0
.long L_multivalue_underflow .long L_multivalue_underflow
.byte 0 .byte 0
.byte 0 .byte 0
L_call: L_call:
call *8(%eax) # goooooooo call *8(%ecx) # goooooooo
# now we're back # now we're back
ik_underflow_handler: ik_underflow_handler:
movl %eax, -8(%esp) # store the return value movl %eax, -8(%esp) # store the return value

25
src/ikarus-exec.c
View File

@ -22,25 +22,24 @@
#include <assert.h> #include <assert.h>
#include <string.h> #include <string.h>
typedef struct {
ikptr tag;
ikptr top;
long int size;
ikptr next;
} cont;
#undef DEBUG_EXEC
ikptr ik_exec_code(ikpcb* pcb, ikptr code_ptr){ ikptr ik_exec_code(ikpcb* pcb, ikptr code_ptr, ikptr argcount, ikptr cp){
ikptr argc = ik_asm_enter(pcb, code_ptr+off_code_data,0); ikptr argc = ik_asm_enter(pcb, code_ptr+off_code_data, argcount, cp);
ikptr next_k = pcb->next_k; ikptr next_k = pcb->next_k;
while(next_k){ while(next_k){
cont* k = (cont*)(long)(next_k - vector_tag); cont* k = (cont*)(long)(next_k - vector_tag);
ikptr top = k->top; ikptr top = k->top;
ikptr rp = ref(top, 0); ikptr rp = ref(top, 0);
long int framesize = (long int) ref(rp, disp_frame_size); long int framesize = (long int) ref(rp, disp_frame_size);
#ifdef DEBUG_EXEC
fprintf(stderr, "exec framesize=0x%016lx ksize=%ld rp=0x%016lx\n",
framesize, k->size, rp);
#endif
if(framesize <= 0){ if(framesize <= 0){
fprintf(stderr, "invalid framesize %ld\n", framesize); fprintf(stderr, "invalid framesize %ld\n", framesize);
exit(-1); exit(-10);
} }
if(framesize < k->size){ if(framesize < k->size){
cont* nk = (cont*)(long)ik_unsafe_alloc(pcb, sizeof(cont)); cont* nk = (cont*)(long)ik_unsafe_alloc(pcb, sizeof(cont));
@ -53,6 +52,14 @@ ikptr ik_exec_code(ikpcb* pcb, ikptr code_ptr){
/* record side effect */ /* record side effect */
unsigned long int idx = ((unsigned long int)(&k->next)) >> pageshift; unsigned long int idx = ((unsigned long int)(&k->next)) >> pageshift;
((unsigned int*)(long)(pcb->dirty_vector))[idx] = -1; ((unsigned int*)(long)(pcb->dirty_vector))[idx] = -1;
} else if (framesize > k->size) {
fprintf(stderr,
"ikarus internal error: invalid framesize %ld, expected %ld or less\n",
framesize, k->size);
long int offset = ref(rp, disp_frame_offset);
fprintf(stderr, "rp = 0x%016lx\n", rp);
fprintf(stderr, "rp offset = %ld\n", offset);
exit(-10);
} }
pcb->next_k = k->next; pcb->next_k = k->next;
ikptr fbase = pcb->frame_base - wordsize; ikptr fbase = pcb->frame_base - wordsize;

2
src/ikarus-fasl.c
View File

@ -110,7 +110,7 @@ void ik_fasl_load(ikpcb* pcb, char* fasl_file){
} }
close(fd); close(fd);
} }
ikptr val = ik_exec_code(pcb, v); ikptr val = ik_exec_code(pcb, v, 0, 0);
if(val != void_object){ if(val != void_object){
ik_print(val); ik_print(val);
} }

137
src/ikarus-ffi.c
View File

@ -7,6 +7,8 @@
#include <stdlib.h> #include <stdlib.h>
#include <strings.h> #include <strings.h>
#undef DEBUG_FFI
static void* static void*
alloc(size_t n, int m) { alloc(size_t n, int m) {
void* x = calloc(n, m); void* x = calloc(n, m);
@ -126,10 +128,103 @@ ikrt_ffi_prep_cif(ikptr rtptr, ikptr argstptr, ikpcb* pcb) {
} }
} }
/* FIXME: handle stack overflow */
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
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));
nk->tag = k->tag;
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;
pcb->frame_pointer = frame_pointer - wordsize;
#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
}
return void_object;
}
ikptr
ikrt_call_back(ikptr proc, ikpcb* pcb) {
ikrt_seal_scheme_stack(pcb);
ikptr old_k = pcb->next_k;
pcb->next_k = 0;
ikptr entry_point = ref(proc, off_closure_code);
ikptr system_stack = pcb->system_stack;
#ifdef DEBUG_FFI
fprintf(stderr, "system_stack = 0x%016lx\n", pcb->system_stack);
#endif
ikptr code_ptr = entry_point - off_code_data;
ikptr rv = ik_exec_code(pcb, code_ptr, 0, proc);
#ifdef DEBUG_FFI
fprintf(stderr, "system_stack = 0x%016lx\n", pcb->system_stack);
#endif
ikptr rv2 = ref(pcb->frame_pointer, -2*wordsize);
#ifdef DEBUG_FFI
fprintf(stderr, "rv=0x%016lx 0x%016lx\n", rv, rv2);
#endif
pcb->next_k = old_k;
pcb->frame_pointer = pcb->frame_base - wordsize;
#ifdef DEBUG_FFI
fprintf(stderr, "rp=0x%016lx\n", ref(pcb->frame_pointer, 0));
#endif
pcb->system_stack = system_stack;
return rv2;
}
ikptr ikptr
ikrt_ffi_call(ikptr data, ikptr argsvec, ikpcb* pcb) { ikrt_ffi_call(ikptr data, ikptr argsvec, ikpcb* pcb) {
ikrt_seal_scheme_stack(pcb);
ikptr cifptr = ref(data, off_vector_data + 0 * wordsize); ikptr cifptr = ref(data, off_vector_data + 0 * wordsize);
ikptr funptr = ref(data, off_vector_data + 1 * wordsize); ikptr funptr = ref(data, off_vector_data + 1 * wordsize);
ikptr typevec = ref(data, off_vector_data + 2 * wordsize); ikptr typevec = ref(data, off_vector_data + 2 * wordsize);
@ -151,6 +246,11 @@ ikrt_ffi_call(ikptr data, ikptr argsvec, ikpcb* pcb) {
for(i=0; i<n; i++){ for(i=0; i<n; i++){
free(avalues[i]); free(avalues[i]);
} }
#ifdef DEBUG_FFI
fprintf(stderr, "DONE WITH CALL, RV=0x%016lx 0x%016lx\n",
(long)val,
ref(pcb->frame_pointer, -2*wordsize));
#endif
free(avalues); free(avalues);
free(rvalue); free(rvalue);
return val; return val;
@ -179,6 +279,7 @@ ffi_status ffi_prep_closure_loc (
*/ */
extern ikpcb* the_pcb;
static void static void
generic_callback(ffi_cif *cif, void *ret, void **args, void *user_data){ generic_callback(ffi_cif *cif, void *ret, void **args, void *user_data){
/* convert args according to cif to scheme values */ /* convert args according to cif to scheme values */
@ -191,8 +292,28 @@ generic_callback(ffi_cif *cif, void *ret, void **args, void *user_data){
ikptr argtypes_conv = ref(data, off_vector_data + 2 * wordsize); ikptr argtypes_conv = ref(data, off_vector_data + 2 * wordsize);
ikptr rtype_conv = ref(data, off_vector_data + 3 * wordsize); ikptr rtype_conv = ref(data, off_vector_data + 3 * wordsize);
fprintf(stderr, "in generic_callback\n"); ikpcb* pcb = the_pcb;
exit(-1); ikptr old_system_stack = pcb->system_stack; /* preserve */
ikptr old_next_k = pcb->next_k; /* preserve */
pcb->next_k = 0;
ikptr code_entry = ref(proc, off_closure_code);
ikptr code_ptr = code_entry - off_code_data;
ikptr frame_pointer = pcb->frame_pointer;
ikptr frame_base = pcb->frame_base;
if ((frame_base - wordsize) != frame_pointer) {
fprintf(stderr, "ikarus internal error: INVALID FRAME LAYOUT 0x%016lx .. 0x%016lx\n",
frame_base, frame_pointer);
exit(-1);
}
ref(frame_pointer, -2*wordsize) = fix(*((int*)args[0]));
ikptr rv = ik_exec_code(pcb, code_ptr, fix(-1), proc);
ikptr rv2 = ref(pcb->frame_pointer, -2*wordsize);
#ifdef DEBUG_FFI
fprintf(stderr, "and back with rv=0x%016lx 0x%016lx!\n", rv, rv2);
#endif
pcb->system_stack = old_system_stack;
pcb->next_k = old_next_k;
*((ikptr*)ret) = unfix(rv2);
return; return;
} }
@ -228,9 +349,9 @@ ikrt_prepare_callback(ikptr data, ikpcb* pcb){
} }
int ho (int(*f)(int), int n) { int ho (int(*f)(int), int n) {
fprintf(stderr, "HO HO 0x%016lx!\n", (long)f); // fprintf(stderr, "HO HO 0x%016lx!\n", (long)f);
int n0 = f(n); int n0 = f(n);
fprintf(stderr, "GOT N0\n"); // fprintf(stderr, "GOT N0\n");
return n0 + f(n); return n0 + f(n);
} }
@ -238,9 +359,9 @@ int ho (int(*f)(int), int n) {
int ho2 (ikptr fptr, ikptr nptr) { int ho2 (ikptr fptr, ikptr nptr) {
int (*f)(int) = (int(*)(int)) ref(fptr, off_pointer_data); int (*f)(int) = (int(*)(int)) ref(fptr, off_pointer_data);
int n = unfix(nptr); int n = unfix(nptr);
fprintf(stderr, "HO2 HO2 0x%016lx!\n", (long)f); // fprintf(stderr, "HO2 HO2 0x%016lx!\n", (long)f);
int n0 = f(n); int n0 = f(n);
fprintf(stderr, "GOT N0\n"); // fprintf(stderr, "GOT N0\n");
return n0 + f(n); return n0 + f(n);
} }
@ -260,8 +381,8 @@ void hello_world(int n) {
#else #else
ikptr ikrt_ffi_prep_cif() { return false_object; } ikptr ikrt_ffi_prep_cif() { return false_object; }
ikrt_ffi_call() { return false_object; } ikptr ikrt_ffi_call() { return false_object; }
ikrt ikrt_prepare_callback() { return false_object; } ikptr ikrt_prepare_callback() { return false_object; }
#endif #endif

2
src/ikarus-main.c
View File

@ -34,8 +34,8 @@
void register_handlers(); void register_handlers();
void register_alt_stack(); void register_alt_stack();
ikpcb* the_pcb;
ikpcb* the_pcb;
int int
file_exists(char* filename){ file_exists(char* filename){