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
./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

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

2
scheme/last-revision
View File

@ -1 +1 @@
1600
1601

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

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

14
src/ikarus-data.h
View File

@ -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);

38
src/ikarus-enter.S
View File

@ -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

25
src/ikarus-exec.c
View File

@ -22,25 +22,24 @@
#include <assert.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 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;

2
src/ikarus-fasl.c
View File

@ -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);
}

135
src/ikarus-ffi.c
View File

@ -7,6 +7,8 @@
#include <stdlib.h>
#include <strings.h>
#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; i<n; 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(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");
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

2
src/ikarus-main.c
View File

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