Commit 125c1d07 authored by Jean-Claude Beaudoin's avatar Jean-Claude Beaudoin
Browse files

First fully operational version.

parent 64b38253
......@@ -30,7 +30,8 @@ struct mkcl_fficall_reg {
float s[MAX_VFP_REGISTERS];
double d[MAX_VFP_REGISTERS/2];
} vfp;
int vfp_register_count;
bool vfp_register_allocated[MAX_VFP_REGISTERS];
int vfp_register_least_unallocated;
};
struct mkcl_fficall_reg *
......@@ -40,30 +41,28 @@ mkcl_fficall_prepare_extra(MKCL, struct mkcl_fficall_reg *registers)
registers = mkcl_alloc(env, sizeof(*registers));
}
registers->core_register_count = 0;
registers->vfp_register_count = 0;
registers->vfp_register_least_unallocated = 0;
{
int i = 0;
for (; i < MAX_VFP_REGISTERS; i++) registers->vfp_register_allocated[i] = FALSE;
}
return registers;
}
#if 0
struct mkcl_fficall_reg *
mkcl_fficall_prepare_extra(MKCL, struct mkcl_fficall_reg *registers)
{
/* No need to prepare registers */
return 0;
}
#endif
void
mkcl_fficall_push_arg(MKCL, union mkcl_ffi_values *data, enum mkcl_ffi_tag type)
{
long i;
long word;
struct mkcl_fficall *fficall = env->fficall;
struct mkcl_fficall_reg *registers = fficall->registers;
switch (type) {
case MKCL_FFI_CHAR: i = data->c; goto INT;
case MKCL_FFI_UNSIGNED_CHAR: i = data->uc; goto INT;
case MKCL_FFI_BYTE: i = data->b; goto INT;
case MKCL_FFI_UNSIGNED_BYTE: i = data->ub; goto INT;
case MKCL_FFI_SHORT: i = data->s; goto INT;
case MKCL_FFI_UNSIGNED_SHORT: i = data->us; goto INT;
case MKCL_FFI_CHAR: word = data->c; goto WORD_WIDE;
case MKCL_FFI_UNSIGNED_CHAR: word = data->uc; goto WORD_WIDE;
case MKCL_FFI_BYTE: word = data->b; goto WORD_WIDE;
case MKCL_FFI_UNSIGNED_BYTE: word = data->ub; goto WORD_WIDE;
case MKCL_FFI_SHORT: word = data->s; goto WORD_WIDE;
case MKCL_FFI_UNSIGNED_SHORT: word = data->us; goto WORD_WIDE;
case MKCL_FFI_INT:
case MKCL_FFI_LONG:
case MKCL_FFI_UNSIGNED_INT:
......@@ -71,27 +70,66 @@ mkcl_fficall_push_arg(MKCL, union mkcl_ffi_values *data, enum mkcl_ffi_tag type)
case MKCL_FFI_POINTER_VOID:
case MKCL_FFI_CSTRING:
case MKCL_FFI_OBJECT:
i = data->i;
INT:
mkcl_fficall_align4(env);
mkcl_fficall_push_int(env, i);
word = data->l;
WORD_WIDE:
if (registers->core_register_count < MAX_CORE_REGISTERS) {
registers->r[registers->core_register_count++] = word;
} else {
mkcl_fficall_align4(env);
mkcl_fficall_push_bytes(env, &word, sizeof(long));
}
break;
case MKCL_FFI_LONG_DOUBLE:
case MKCL_FFI_DOUBLE:
mkcl_fficall_align4(env);
mkcl_fficall_push_bytes(env, &data->d, sizeof(double));
if (registers->vfp_register_least_unallocated < (MAX_VFP_REGISTERS - 1)) {
int least_unallocated_pair = registers->vfp_register_least_unallocated;
if (least_unallocated_pair & 1) least_unallocated_pair++; /* round up to next pair */
for (; (least_unallocated_pair < MAX_VFP_REGISTERS)
&& (registers->vfp_register_allocated[least_unallocated_pair]
|| registers->vfp_register_allocated[least_unallocated_pair + 1])
; least_unallocated_pair += 2);
if (least_unallocated_pair < MAX_VFP_REGISTERS) {
registers->vfp.d[least_unallocated_pair / 2] = data->d;
registers->vfp_register_allocated[least_unallocated_pair++] = TRUE;
registers->vfp_register_allocated[least_unallocated_pair++] = TRUE;
{
int i = least_unallocated_pair;
for (i++; (i < MAX_VFP_REGISTERS) && registers->vfp_register_allocated[i]; i++);
registers->vfp_register_least_unallocated = i;
}
} else {
registers->vfp_register_least_unallocated = MAX_VFP_REGISTERS; /* this ends back-filling */
mkcl_fficall_align8(env);
mkcl_fficall_push_bytes(env, &data->d, sizeof(double));
}
} else {
registers->vfp_register_least_unallocated = MAX_VFP_REGISTERS; /* this ends back-filling */
mkcl_fficall_align8(env);
mkcl_fficall_push_bytes(env, &data->d, sizeof(double));
}
break;
case MKCL_FFI_FLOAT:
mkcl_fficall_align4(env);
mkcl_fficall_push_bytes(env, &data->f, sizeof(float));
break;
case MKCL_FFI_LONG_DOUBLE:
mkcl_fficall_align4(env);
mkcl_fficall_push_bytes(env, &data->d, sizeof(long double));
if (registers->vfp_register_least_unallocated < MAX_VFP_REGISTERS) {
int i = registers->vfp_register_least_unallocated;
registers->vfp.s[i] = data->f;
registers->vfp_register_allocated[i] = TRUE;
for (i++; (i < MAX_VFP_REGISTERS) && registers->vfp_register_allocated[i]; i++);
registers->vfp_register_least_unallocated = i;
} else {
mkcl_fficall_align4(env);
mkcl_fficall_push_bytes(env, &data->f, sizeof(float));
}
break;
case MKCL_FFI_UNSIGNED_LONG_LONG:
case MKCL_FFI_LONG_LONG:
mkcl_fficall_align4(env);
mkcl_fficall_push_bytes(env, &data->ull, sizeof(unsigned long long));
if (registers->core_register_count < (MAX_CORE_REGISTERS - 1)) {
registers->r[registers->core_register_count++] = data->l2[0];
registers->r[registers->core_register_count++] = data->l2[1];
} else {
mkcl_fficall_align8(env);
mkcl_fficall_push_bytes(env, &data->ull, sizeof(unsigned long long));
}
break;
case MKCL_FFI_VOID:
mkcl_FEerror(env, "VOID is not a valid argument type for a C function", 0);
......@@ -155,7 +193,7 @@ mkcl_fficall_execute(MKCL, void *f_ptr, struct mkcl_fficall *fficall, enum mkcl_
regs->vfp.d[4], regs->vfp.d[5], regs->vfp.d[6], regs->vfp.d[7]);
} else if ((return_type == MKCL_FFI_POINTER_VOID)
|| (return_type == MKCL_FFI_CSTRING)
|| (return_type == MKCL_FFI_FLOAT)) {
|| (return_type == MKCL_FFI_OBJECT)) {
fficall->output.pv
= ((ptr_ffunc) f_ptr) (regs->r[0], regs->r[1], regs->r[2], regs->r[3],
regs->vfp.d[0], regs->vfp.d[1], regs->vfp.d[2], regs->vfp.d[3],
......@@ -198,40 +236,39 @@ mkcl_fficall_execute(MKCL, void *f_ptr, struct mkcl_fficall *fficall, enum mkcl_
static const mkcl_base_string_object(mkcl_dynamic_callback_import_thread_name__obj_, "mkcl_dynamic_callback_execute");
static const mkcl_object mkcl_dynamic_callback_import_thread_name = (mkcl_object) &mkcl_dynamic_callback_import_thread_name__obj_;
static void
mkcl_dynamic_callback_execute(mkcl_object cbk_info, char *arg_buffer)
static union mkcl_ffi_values
mkcl_dynamic_callback_execute(long i1, long i2, long i3, long i4,
double d0, double d1, double d2, double d3,
double d4, double d5, double d6, double d7,
mkcl_object cbk_info, char *arg_buffer)
{
char stack_mark = 0;
mkcl_object fun, rtype, argtypes;
mkcl_object result;
mkcl_index i, size;
union mkcl_ffi_values output;
enum mkcl_ffi_tag tag;
mkcl_env env = MKCL_ENV();
mkcl_env imported_env = NULL;
mkcl_object fun = MKCL_CAR(cbk_info);
mkcl_object rtype = MKCL_CADR(cbk_info);
mkcl_object argtypes = MKCL_CADDR(cbk_info);
arg_buffer += sizeof(void *); /* Skip saved stack frame pointer */
arg_buffer += sizeof(void *); /* Skip return address */
if (env == NULL)
{
env = imported_env = mkcl_import_current_thread(mkcl_dynamic_callback_import_thread_name, mk_cl_Cnil, NULL, NULL);
if (imported_env == NULL)
/* In the normal case we always set errno = 0, so this is clearly an error situation. */
{ errno = ENOMEM; return; }
{ union mkcl_ffi_values val; val.ll = 0; errno = ENOMEM; return val; }
}
MKCL_BUILD_TEMP_STACK_FRAME(env, frame, aux);
fun = MKCL_CAR(cbk_info);
rtype = MKCL_CADR(cbk_info);
argtypes = MKCL_CADDR(cbk_info);
arg_buffer += sizeof(void *); /* Skip saved stack frame pointer */
arg_buffer += sizeof(void *); /* Skip return address */
for (i=0; !mkcl_endp(env, argtypes); argtypes = MKCL_CDR(argtypes), i++) {
tag = mkcl_foreign_type_code(env, MKCL_CAR(argtypes));
size = mkcl_fixnum_to_word(mk_si_size_of_foreign_elt_type(env, MKCL_CAR(argtypes)));
for (; !mkcl_endp(env, argtypes); argtypes = MKCL_CDR(argtypes)) {
enum mkcl_ffi_tag tag = mkcl_foreign_type_code(env, MKCL_CAR(argtypes));
mkcl_index size = mkcl_fixnum_to_word(mk_si_size_of_foreign_elt_type(env, MKCL_CAR(argtypes)));
result = mkcl_foreign_ref_elt(env, arg_buffer, tag);
mkcl_temp_stack_frame_push(env, frame,result);
mkcl_temp_stack_frame_push(env, frame, result);
{
mkcl_index sp = (size + 0x03) & ~((mkcl_index) 0x03);
arg_buffer += (sp);
......@@ -251,11 +288,7 @@ mkcl_dynamic_callback_execute(mkcl_object cbk_info, char *arg_buffer)
result = mkcl_apply_from_temp_stack_frame(env, frame, fun);
mkcl_disable_interrupts(env);
#if 1
mkcl_cleanup_thread_lisp_context(env);
#else
mkcl_bds_unwind1(env);
#endif
} MKCL_CATCH_ALL_END;
thread->thread.status = mkcl_thread_done;
}
......@@ -263,102 +296,109 @@ mkcl_dynamic_callback_execute(mkcl_object cbk_info, char *arg_buffer)
result = mkcl_apply_from_temp_stack_frame(env, frame, fun);
mkcl_temp_stack_frame_close(env, frame);
tag = mkcl_foreign_type_code(env, rtype);
memset(&output, 0, sizeof(output));
mkcl_foreign_set_elt(env, &output, tag, result);
{
union mkcl_ffi_values output;
enum mkcl_ffi_tag tag = mkcl_foreign_type_code(env, rtype);
if (imported_env)
mkcl_release_current_thread(imported_env);
memset(&output, 0, sizeof(output));
mkcl_foreign_set_elt(env, &output, tag, result);
errno = 0;
switch (tag) {
case MKCL_FFI_CHAR: i = output.c; goto INT;
case MKCL_FFI_UNSIGNED_CHAR: i = output.uc; goto INT;
case MKCL_FFI_BYTE: i = output.b; goto INT;
case MKCL_FFI_UNSIGNED_BYTE: i = output.ub; goto INT;
case MKCL_FFI_SHORT: i = output.s; goto INT;
case MKCL_FFI_UNSIGNED_SHORT: i = output.us; goto INT;
if (imported_env)
mkcl_release_current_thread(imported_env);
case MKCL_FFI_POINTER_VOID:
case MKCL_FFI_OBJECT:
case MKCL_FFI_CSTRING:
case MKCL_FFI_INT:
case MKCL_FFI_UNSIGNED_INT:
case MKCL_FFI_LONG:
case MKCL_FFI_UNSIGNED_LONG:
i = output.i;
INT:
#if 0 /* this code is x86 legacy. */
#ifdef _MSC_VER
__asm mov eax,i
#else
{
register int eax asm("eax");
eax = i;
}
#endif
#endif
return;
case MKCL_FFI_LONG_LONG:
case MKCL_FFI_UNSIGNED_LONG_LONG:
#if 0 /* this code is x86 legacy. */
# ifdef _MSC_VER
__asm mov eax,output.l2[0]
__asm mov edx,output.l2[1]
# else
{
register int eax asm("eax");
register int edx asm("edx");
eax = output.l2[0];
edx = output.l2[1];
}
# endif
#endif
return;
case MKCL_FFI_DOUBLE: {
#if 0 /* this code is x86 legacy. */
#ifdef _MSC_VER
__asm fld output.d
#else
{
asm("fldl (%0)" :: "a" (&output.d));
}
#endif
#endif
return;
}
case MKCL_FFI_LONG_DOUBLE: {
#if 0 /* this code is x86 legacy. */
#ifdef _MSC_VER
__asm fld output.ld
#else
{
asm("fldt (%0)" :: "a" (&output.ld));
}
#endif
#endif
return;
}
case MKCL_FFI_FLOAT: {
#if 0 /* this code is x86 legacy. */
#ifdef _MSC_VER
__asm fld output.f
#else
{
asm("flds (%0)" :: "a" (&output.f));
}
#endif
#endif
return;
}
case MKCL_FFI_VOID:
return;
default:
mkcl_FEerror(env, "Invalid C function callback return type", 0);
errno = 0; /* See above for the necessity of this. */
return output;
}
}
static void
mkcl_void_dynamic_callback_execute(long i1, long i2, long i3, long i4,
double d0, double d1, double d2, double d3,
double d4, double d5, double d6, double d7,
mkcl_object cbk_info, char *arg_buffer)
{
(void) mkcl_dynamic_callback_execute(i1, i2, i3, i4, d0, d1, d2, d3, d4, d5, d6, d7, cbk_info, arg_buffer);
}
static mkcl_int8_t
mkcl_byte_dynamic_callback_execute(long i1, long i2, long i3, long i4,
double d0, double d1, double d2, double d3,
double d4, double d5, double d6, double d7,
mkcl_object cbk_info, char *arg_buffer)
{
union mkcl_ffi_values val
= mkcl_dynamic_callback_execute(i1, i2, i3, i4, d0, d1, d2, d3, d4, d5, d6, d7, cbk_info, arg_buffer);
return val.b;
}
static short
mkcl_short_dynamic_callback_execute(long i1, long i2, long i3, long i4,
double d0, double d1, double d2, double d3,
double d4, double d5, double d6, double d7,
mkcl_object cbk_info, char *arg_buffer)
{
union mkcl_ffi_values val
= mkcl_dynamic_callback_execute(i1, i2, i3, i4, d0, d1, d2, d3, d4, d5, d6, d7, cbk_info, arg_buffer);
return val.s;
}
static long
mkcl_long_dynamic_callback_execute(long i1, long i2, long i3, long i4,
double d0, double d1, double d2, double d3,
double d4, double d5, double d6, double d7,
mkcl_object cbk_info, char *arg_buffer)
{
union mkcl_ffi_values val
= mkcl_dynamic_callback_execute(i1, i2, i3, i4, d0, d1, d2, d3, d4, d5, d6, d7, cbk_info, arg_buffer);
return val.l;
}
static long long
mkcl_long_long_dynamic_callback_execute(long i1, long i2, long i3, long i4,
double d0, double d1, double d2, double d3,
double d4, double d5, double d6, double d7,
mkcl_object cbk_info, char *arg_buffer)
{
union mkcl_ffi_values val
= mkcl_dynamic_callback_execute(i1, i2, i3, i4, d0, d1, d2, d3, d4, d5, d6, d7, cbk_info, arg_buffer);
return val.ll;
}
static float
mkcl_float_dynamic_callback_execute(long i1, long i2, long i3, long i4,
double d0, double d1, double d2, double d3,
double d4, double d5, double d6, double d7,
mkcl_object cbk_info, char *arg_buffer)
{
union mkcl_ffi_values val
= mkcl_dynamic_callback_execute(i1, i2, i3, i4, d0, d1, d2, d3, d4, d5, d6, d7, cbk_info, arg_buffer);
return val.f;
}
static double
mkcl_double_dynamic_callback_execute(long i1, long i2, long i3, long i4,
double d0, double d1, double d2, double d3,
double d4, double d5, double d6, double d7,
mkcl_object cbk_info, char *arg_buffer)
{
union mkcl_ffi_values val
= mkcl_dynamic_callback_execute(i1, i2, i3, i4, d0, d1, d2, d3, d4, d5, d6, d7, cbk_info, arg_buffer);
return val.d;
}
static long double
mkcl_long_double_dynamic_callback_execute(long i1, long i2, long i3, long i4,
double d0, double d1, double d2, double d3,
double d4, double d5, double d6, double d7,
mkcl_object cbk_info, char *arg_buffer)
{
union mkcl_ffi_values val
= mkcl_dynamic_callback_execute(i1, i2, i3, i4, d0, d1, d2, d3, d4, d5, d6, d7, cbk_info, arg_buffer);
return val.ld;
}
void *
mkcl_dynamic_callback_make(MKCL, mkcl_object data, enum mkcl_ffi_calling_convention cc_type)
......@@ -373,80 +413,68 @@ mkcl_dynamic_callback_make(MKCL, mkcl_object data, enum mkcl_ffi_calling_convent
#define immed32(val_long) imm.l = (val_long); i(imm.b[0]); i(imm.b[1]); i(imm.b[2]); i(imm.b[3]);
#if 0 /* this code is x86 legacy. */
/* pushl %ebp */ i(0x55); /* build stack frame, step 1 of 2 */
/* movl %esp, %ebp */ i(0x89); i(0xe5); /* build stack frame, step 2 of 2 */
/* pushl %esp */ i(0x54); /* push arg_list pointer */
/* movl <addr32>, %eax */ i(0xb8); immed_ptr(data);
/* pushl %eax */ i(0x50); /* push data */
/* movl <addr32>, %eax */ i(0xb8); immed_ptr(mkcl_dynamic_callback_execute);
/* call *%eax */ i(0xff); i(0xd0); /* call mkcl_dynamic_callback_execute() */
/* addl $16, %esp */ i(0x83); i(0xc4); i(0x10); /* cleanup arg list of previous call, 16 bytes. */
/* leave */ i(0xc9); /* undo stack frame */
#endif
#if MKCL_UNIX
# if 0 /* this code is x86 legacy. */
/* ret */ i(0xc3); /* return */
# endif
#elif MKCL_WINDOWS
if (cc_type == MKCL_FFI_CC_CDECL) {
/* ret */ i(0xc3); /* return */
} else { /* This would be MKCL_FFI_CC_STDCALL. JCB */
mkcl_object arg_types = MKCL_CADDR(data);
unsigned long arg_list_byte_size = 0;
const unsigned long mask = 3;
while (MKCL_CONSP(arg_types)) {
unsigned int sz = mkcl_fixnum_to_word(mk_si_size_of_foreign_elt_type(env, MKCL_CAR(arg_types)));
arg_list_byte_size += ((sz+mask)&(~mask));
arg_types = MKCL_CDR(arg_types);
}
enum mkcl_ffi_tag tag = mkcl_foreign_type_code(env, MKCL_CADR(data));
void * fptr = 0;
if (arg_list_byte_size > USHRT_MAX)
{
# if 0 /* this code is x86 legacy. */
/* popl %ecx */ i(0x59); /* get return %eip. */
/* addl <immed32>, %esp */ i(0x81); i(0xc4); immed32(arg_list_byte_size); /* pop byte_size bytes. */
/* jmp *%ecx */ i(0xff); i(0xe1); /* jump to return %eip. */
# endif
}
else
{
# if 0 /* this code is x86 legacy. */
/* ret <immed16> */ i(0xc2); immed16(arg_list_byte_size); /* return and pop byte_size bytes. */
# endif
}
switch (tag) {
case MKCL_FFI_CHAR:
case MKCL_FFI_UNSIGNED_CHAR:
case MKCL_FFI_BYTE:
case MKCL_FFI_UNSIGNED_BYTE:
fptr = mkcl_byte_dynamic_callback_execute;
break;
case MKCL_FFI_SHORT:
case MKCL_FFI_UNSIGNED_SHORT:
fptr = mkcl_short_dynamic_callback_execute;
break;
case MKCL_FFI_POINTER_VOID:
case MKCL_FFI_OBJECT:
case MKCL_FFI_CSTRING:
case MKCL_FFI_INT:
case MKCL_FFI_UNSIGNED_INT:
case MKCL_FFI_LONG:
case MKCL_FFI_UNSIGNED_LONG:
fptr = mkcl_long_dynamic_callback_execute;
break;
case MKCL_FFI_LONG_LONG:
case MKCL_FFI_UNSIGNED_LONG_LONG:
fptr = mkcl_long_long_dynamic_callback_execute;
break;
case MKCL_FFI_DOUBLE:
fptr = mkcl_double_dynamic_callback_execute;
break;
case MKCL_FFI_LONG_DOUBLE:
fptr = mkcl_long_double_dynamic_callback_execute;
break;
case MKCL_FFI_FLOAT:
fptr = mkcl_float_dynamic_callback_execute;
break;
case MKCL_FFI_VOID:
fptr = mkcl_void_dynamic_callback_execute;
break;
default:
mkcl_FEerror(env, "Invalid C function callback return type", 0);
}
#else
# error Incomplete mkcl_dynamic_callback_make().
#endif
#if 0 /* this code is x86 legacy. */
/* nop */ i(0x90); /* Fill with nop until end of I-cache line (multiple of 16 bytes). */
/* nop */ i(0x90);
/* nop */ i(0x90);
/* nop */ i(0x90);
/* nop */ i(0x90);
/* nop */ i(0x90);
#endif
#if MKCL_UNIX
int rc = mprotect(buf, mkcl_core.pagesize, PROT_READ | /* PROT_WRITE | */ PROT_EXEC);
if (rc)
mkcl_FElibc_error(env, "mkcl_dynamic_callback_make() failed on mprotect()", 0);
#elif MKCL_WINDOWS
{ /* By default on Win64 data is PAGE_READWRITE only and we would get
an ACCESS_VIOLATION if we didn't set it to EXECUTE. */
/* Not really needed on Win32 but we do it for uniformity with other platforms. */
DWORD old_protection_flags;
BOOL ok = VirtualProtect(buf, mkcl_core.pagesize, PAGE_EXECUTE_READ, &old_protection_flags);
if (!ok)
mkcl_FEwin32_error(env, "mkcl_dynamic_callback_make() failed on VirtualProtect()", 0);
i(0x7B); i(0x46); /* mov r3, pc */
i(0x03); i(0xF1); i(0x18); i(0x03); /* add r3, #24 */
i(0x10); i(0xB5); /* push {r4, lr} */
i(0x1A); i(0x68); /* ldr r2, [r3] */ /* pointer to trampoline */
i(0x58); i(0x68); /* ldr r0, [r3, #4] */ /* arg0 */
i(0x69); i(0x46); /* mov r1, sp */ /* arg1 */
i(0x90); i(0x47); /* blx r2 */ /* call the callback trampoline */
i(0x10); i(0xBD); /* pop {r4, pc} */ /* return to caller. */
i(0x00); i(0xBF); /* nop */
i(0x00); i(0xBF); /* nop */
i(0x00); i(0xBF); /* .align 2 */
immed_ptr(fptr); /* The code here above expect this pointer to be 24 bytes (0x18) after the first opcode. */
immed_ptr(data); /* The code here above expect this pointer to be 4 bytes after the previous one. */
{
int rc = mprotect(buf, mkcl_core.pagesize, PROT_READ | /* PROT_WRITE | */ PROT_EXEC);
if (rc)
mkcl_FElibc_error(env, "mkcl_dynamic_callback_make() failed on mprotect()", 0);
}
#endif
#if 0
printf("\nIn mkcl_dynamic_callback_make(), returning %p.\n", buf); fflush(NULL); /* debug JCB */
#endif
return buf;
}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment