From e07d8f97603ea8fccdfa8d31476f1ce7aa11622d Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Sun, 21 Sep 2008 04:08:54 -0400 Subject: [PATCH] ffi callbacks sorta kinda work now. --- c32 | 6 +- lab/test-ffi.ss | 37 ++++++++ scheme/ikarus.pointers.ss | 4 +- scheme/last-revision | 2 +- scheme/pass-specify-rep-primops.ss | 3 +- src/ikarus-data.h | 14 ++- src/ikarus-enter.S | 38 ++++---- src/ikarus-exec.c | 25 ++++-- src/ikarus-fasl.c | 2 +- src/ikarus-ffi.c | 137 +++++++++++++++++++++++++++-- src/ikarus-main.c | 2 +- 11 files changed, 224 insertions(+), 46 deletions(-) create mode 100644 lab/test-ffi.ss diff --git a/c32 b/c32 index 7deb54c..a8ba3cd 100755 --- a/c32 +++ b/c32 @@ -1,6 +1,10 @@ #!/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 diff --git a/lab/test-ffi.ss b/lab/test-ffi.ss new file mode 100644 index 0000000..008f036 --- /dev/null +++ b/lab/test-ffi.ss @@ -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") diff --git a/scheme/ikarus.pointers.ss b/scheme/ikarus.pointers.ss index 70a4181..aecaa7b 100644 --- a/scheme/ikarus.pointers.ss +++ b/scheme/ikarus.pointers.ss @@ -160,7 +160,9 @@ (unless (= (vector-length argsvec) (vector-length argtypes-n)) (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) (let-values ([(cif argtypes-n rtype-n) diff --git a/scheme/last-revision b/scheme/last-revision index b67470f..f70509d 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1600 +1601 diff --git a/scheme/pass-specify-rep-primops.ss b/scheme/pass-specify-rep-primops.ss index de8d0ca..fc838f4 100644 --- a/scheme/pass-specify-rep-primops.ss +++ b/scheme/pass-specify-rep-primops.ss @@ -2354,7 +2354,8 @@ [(P) (prm '= (prm 'int+ (prm 'mref pcr (K pcb-frame-base)) - (K (- wordsize))) fpr)]) + (K (- wordsize))) + fpr)]) (define-primop $current-frame unsafe [(V) (prm 'mref pcr (K pcb-next-continuation))]) diff --git a/src/ikarus-data.h b/src/ikarus-data.h index f075855..3cb2adb 100644 --- a/src/ikarus-data.h +++ b/src/ikarus-data.h @@ -174,6 +174,16 @@ typedef struct ikpcb{ struct timeval collect_rtime; } ikpcb; +typedef struct { + ikptr tag; + ikptr top; + long int size; + ikptr next; +} cont; + + + + ikpcb* ik_collect(unsigned long int, ikpcb*); 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_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_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_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_underflow_handler(ikpcb*); ikptr ik_unsafe_alloc(ikpcb* pcb, int size); diff --git a/src/ikarus-enter.S b/src/ikarus-enter.S index 17f1d8b..d01a025 100644 --- a/src/ikarus-enter.S +++ b/src/ikarus-enter.S @@ -47,32 +47,31 @@ _ik_asm_enter: mov %r14, -40(%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 # pcb is the first arg, or %rdi # 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 %rcx, %rdi # move closure pointer into cpr mov 0(%rsi), %rbp # allocation pointer is at 0(pcb) sub $64, %rsp # 64 for alignment mov %rsp, 48(%rsi) # save esp in pcb->system_stack mov 16(%rsi), %rsp # load scheme stack from pcb->frame_pinter jmp L_call - .byte 0 - .byte 0 - .byte 0 - .byte 0 - .byte 0 - .byte 0 - .byte 0 - .byte 0 + .quad 8 + .quad 0 L_multivalue_label: # FIXME .quad L_multivalue_underflow .quad 0 L_call: - call *%rax # goooooooo + call *%rdx # goooooooo # now we're back ik_underflow_handler: +_ik_underflow_handler: mov %rax, -16(%rsp) # store the return value mov $-8, %rax # set rvcount = 1 L_do_underflow: @@ -209,32 +208,29 @@ L_back: .align 8 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) # pcb is the first arg 4(%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 %ebp, -8(%esp) # preserve movl 4(%esp), %esi movl 0(%esi), %ebp # allocation pointer is at 0(pcb) - movl %esp, %eax + movl %esp, %ecx subl $16, %esp # 24 for alignment movl %esp, 24(%esi) # save esp in pcb->system_stack movl 8(%esi), %esp # load scheme stack from pcb->frame_pinter jmp L_call - .byte 0 - .byte 0 - .byte 0 - .byte 0 - .byte 0 - .byte 0 - .byte 0 - .byte 0 + .long 4 + .long 0 .long L_multivalue_underflow .byte 0 .byte 0 L_call: - call *8(%eax) # goooooooo + call *8(%ecx) # goooooooo # now we're back ik_underflow_handler: movl %eax, -8(%esp) # store the return value diff --git a/src/ikarus-exec.c b/src/ikarus-exec.c index 24b5a42..934d046 100644 --- a/src/ikarus-exec.c +++ b/src/ikarus-exec.c @@ -22,25 +22,24 @@ #include #include -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 argc = ik_asm_enter(pcb, code_ptr+off_code_data,0); +ikptr ik_exec_code(ikpcb* pcb, ikptr code_ptr, ikptr argcount, ikptr cp){ + ikptr argc = ik_asm_enter(pcb, code_ptr+off_code_data, argcount, cp); ikptr next_k = pcb->next_k; while(next_k){ cont* k = (cont*)(long)(next_k - vector_tag); ikptr top = k->top; ikptr rp = ref(top, 0); 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){ fprintf(stderr, "invalid framesize %ld\n", framesize); - exit(-1); + exit(-10); } if(framesize < k->size){ 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 */ unsigned long int idx = ((unsigned long int)(&k->next)) >> pageshift; ((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; ikptr fbase = pcb->frame_base - wordsize; diff --git a/src/ikarus-fasl.c b/src/ikarus-fasl.c index 2f3e0c3..11a9365 100644 --- a/src/ikarus-fasl.c +++ b/src/ikarus-fasl.c @@ -110,7 +110,7 @@ void ik_fasl_load(ikpcb* pcb, char* fasl_file){ } close(fd); } - ikptr val = ik_exec_code(pcb, v); + ikptr val = ik_exec_code(pcb, v, 0, 0); if(val != void_object){ ik_print(val); } diff --git a/src/ikarus-ffi.c b/src/ikarus-ffi.c index 34a9cd3..7884a6d 100644 --- a/src/ikarus-ffi.c +++ b/src/ikarus-ffi.c @@ -7,6 +7,8 @@ #include #include +#undef DEBUG_FFI + static void* alloc(size_t n, int 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 ikrt_ffi_call(ikptr data, ikptr argsvec, ikpcb* pcb) { + + ikrt_seal_scheme_stack(pcb); + 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); @@ -151,6 +246,11 @@ ikrt_ffi_call(ikptr data, ikptr argsvec, ikpcb* pcb) { for(i=0; iframe_pointer, -2*wordsize)); +#endif free(avalues); free(rvalue); return val; @@ -179,6 +279,7 @@ ffi_status ffi_prep_closure_loc ( */ +extern ikpcb* the_pcb; static void generic_callback(ffi_cif *cif, void *ret, void **args, void *user_data){ /* 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 rtype_conv = ref(data, off_vector_data + 3 * wordsize); - fprintf(stderr, "in generic_callback\n"); - exit(-1); + ikpcb* pcb = the_pcb; + 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; } @@ -228,9 +349,9 @@ ikrt_prepare_callback(ikptr data, ikpcb* pcb){ } 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); - fprintf(stderr, "GOT N0\n"); + // fprintf(stderr, "GOT N0\n"); return n0 + f(n); } @@ -238,9 +359,9 @@ int ho (int(*f)(int), int 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); + // fprintf(stderr, "HO2 HO2 0x%016lx!\n", (long)f); int n0 = f(n); - fprintf(stderr, "GOT N0\n"); + // fprintf(stderr, "GOT N0\n"); return n0 + f(n); } @@ -260,8 +381,8 @@ void hello_world(int n) { #else ikptr ikrt_ffi_prep_cif() { return false_object; } -ikrt_ffi_call() { return false_object; } -ikrt ikrt_prepare_callback() { return false_object; } +ikptr ikrt_ffi_call() { return false_object; } +ikptr ikrt_prepare_callback() { return false_object; } #endif diff --git a/src/ikarus-main.c b/src/ikarus-main.c index 3864f81..86d1820 100644 --- a/src/ikarus-main.c +++ b/src/ikarus-main.c @@ -34,8 +34,8 @@ void register_handlers(); void register_alt_stack(); -ikpcb* the_pcb; +ikpcb* the_pcb; int file_exists(char* filename){