Commit 48be245e authored by Jean-Claude Beaudoin's avatar Jean-Claude Beaudoin
Browse files

First unstubbed version for AARCH64.

parent 4bf93ddf
......@@ -15,18 +15,32 @@
*/
#include <mkcl/mkcl.h>
#include <mkcl/internal.h>
#include <string.h>
#include <sys/mman.h>
#include <mkcl/internal.h>
#define MAX_INT_REGISTERS 4
#define MAX_FP_REGISTERS 16
#define MAX_CORE_REGISTERS 8
#define MAX_VFP_REGISTERS 8
struct hfa_float { float s0; float s1; float s2; float s3; };
struct hfa_double { double d0; double d1; };
struct hva_int { int i0; int i1; int i2; int i3; };
struct hva_long { long l0; long l1; };
struct mkcl_fficall_reg {
long int_registers[MAX_INT_REGISTERS]; /* Shouldn't it be "unsigned" instead? JCB. */
int int_registers_size;
double fp_registers[MAX_FP_REGISTERS];
int fp_registers_size;
long r[MAX_CORE_REGISTERS];
int core_register_count;
union {
float s;
double d;
struct hfa_float hfa_f;
struct hfa_double hfa_d;
struct hva_int hva_i;
struct hva_long hva_l;
} v[MAX_VFP_REGISTERS];
bool vfp_register_allocated[MAX_VFP_REGISTERS];
int vfp_register_least_unallocated;
};
struct mkcl_fficall_reg *
......@@ -35,279 +49,321 @@ mkcl_fficall_prepare_extra(MKCL, struct mkcl_fficall_reg *registers)
if (registers == 0) {
registers = mkcl_alloc(env, sizeof(*registers));
}
registers->int_registers_size = 0;
registers->fp_registers_size = 0;
registers->core_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;
}
void
mkcl_fficall_push_arg(MKCL, union mkcl_ffi_values *data, enum mkcl_ffi_tag type)
{
long i;
long dword;
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_INT: i = data->i; goto INT;
case MKCL_FFI_UNSIGNED_INT: i = data->ui; goto INT;
case MKCL_FFI_POINTER_VOID: dword = (intptr_t) data->pv; goto DWORD_WIDE;
case MKCL_FFI_CSTRING: dword = (intptr_t) data->pc; goto DWORD_WIDE;
case MKCL_FFI_OBJECT: dword = (intptr_t) data->o; goto DWORD_WIDE;
case MKCL_FFI_CHAR: dword = data->c; goto DWORD_WIDE;
case MKCL_FFI_UNSIGNED_CHAR: dword = data->uc; goto DWORD_WIDE;
case MKCL_FFI_BYTE: dword = data->b; goto DWORD_WIDE;
case MKCL_FFI_UNSIGNED_BYTE: dword = data->ub; goto DWORD_WIDE;
case MKCL_FFI_SHORT: dword = data->s; goto DWORD_WIDE;
case MKCL_FFI_UNSIGNED_SHORT: dword = data->us; goto DWORD_WIDE;
case MKCL_FFI_INT: dword = data->i; goto DWORD_WIDE;
case MKCL_FFI_UNSIGNED_INT: dword = data->ui; goto DWORD_WIDE;
case MKCL_FFI_LONG:
case MKCL_FFI_UNSIGNED_LONG:
case MKCL_FFI_LONG_LONG:
case MKCL_FFI_UNSIGNED_LONG_LONG:
case MKCL_FFI_POINTER_VOID:
case MKCL_FFI_CSTRING:
case MKCL_FFI_OBJECT:
i = data->l;
INT:
if (registers->int_registers_size < MAX_INT_REGISTERS) {
registers->int_registers[registers->int_registers_size++] = i;
case MKCL_FFI_LONG_LONG:
dword = data->l;
DWORD_WIDE:
if (registers->core_register_count < MAX_CORE_REGISTERS) {
registers->r[registers->core_register_count++] = dword;
} else {
mkcl_fficall_align8(env);
mkcl_fficall_push_bytes(env, &i, sizeof(long));
mkcl_fficall_push_bytes(env, &dword, sizeof(long));
}
break;
case MKCL_FFI_LONG_DOUBLE:
case MKCL_FFI_DOUBLE:
if (registers->fp_registers_size < MAX_FP_REGISTERS) {
registers->fp_registers[registers->fp_registers_size++] = data->d;
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->v[least_unallocated_pair / 2].d = 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:
if (registers->fp_registers_size < MAX_FP_REGISTERS) {
memset(&registers->fp_registers[registers->fp_registers_size], 0, sizeof(double));
(*(float*)(&registers->fp_registers[registers->fp_registers_size++])) = (float)data->f;
if (registers->vfp_register_least_unallocated < MAX_VFP_REGISTERS) {
int i = registers->vfp_register_least_unallocated;
registers->v[i].s = 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 {
i = 0;
mkcl_fficall_align8(env);
mkcl_fficall_align4(env);
mkcl_fficall_push_bytes(env, &data->f, sizeof(float));
mkcl_fficall_push_bytes(env, &i, sizeof(float));
}
break;
case MKCL_FFI_LONG_DOUBLE:
/* According to the specification, arguments of this type
should be passed on the stack ("in memory" as they say).
*/
mkcl_FEerror(env, "LONG DOUBLE is not implemented yet as argument type for a C function", 0);
break;
case MKCL_FFI_VOID:
mkcl_FEerror(env, "VOID is not a valid argument type for a C function", 0);
default:
mkcl_FEerror(env, "Invalid argument type for a C function", 0);
mkcl_FEerror(env, "Unknown argument type for a C function", 0);
}
}
void
mkcl_fficall_execute(MKCL, void *_f_ptr, struct mkcl_fficall *fficall, enum mkcl_ffi_tag return_type)
mkcl_fficall_execute(MKCL, void *f_ptr, struct mkcl_fficall *fficall, enum mkcl_ffi_tag return_type)
{
struct mkcl_fficall_reg *registers = fficall->registers;
char* buf = fficall->buffer;
void * stack_p;
mkcl_word * const args_buffer = (mkcl_word *) fficall->buffer;
char* stack_p;
size_t bufsize;
mkcl_index btop;
struct mkcl_fficall_reg * regs = fficall->registers;
mkcl_fficall_align16(env); /* Size of a cache line. */
bufsize = fficall->buffer_sp - fficall->buffer;
btop = bufsize / sizeof(mkcl_word);
typedef long (*dword_integral_ffunc)(long x0, long x1, long x2, long x3,
long x4, long x5, long x6, long x7,
double d0, double d1, double d2, double d3,
double d4, double d5, double d6, double d7);
typedef long long (*long_long_ffunc)(long x0, long x1, long x2, long x3,
long x4, long x5, long x6, long x7,
double d0, double d1, double d2, double d3,
double d4, double d5, double d6, double d7);
typedef void * (*ptr_ffunc)(long x0, long x1, long x2, long x3,
long x4, long x5, long x6, long x7,
double d0, double d1, double d2, double d3,
double d4, double d5, double d6, double d7);
typedef float (*float_ffunc)(long x0, long x1, long x2, long x3,
long x4, long x5, long x6, long x7,
double d0, double d1, double d2, double d3,
double d4, double d5, double d6, double d7);
typedef double (*double_ffunc)(long x0, long x1, long x2, long x3,
long x4, long x5, long x6, long x7,
double d0, double d1, double d2, double d3,
double d4, double d5, double d6, double d7);
typedef long double (*long_double_ffunc)(long x0, long x1, long x2, long x3,
long x4, long x5, long x6, long x7,
double d0, double d1, double d2, double d3,
double d4, double d5, double d6, double d7);
typedef void (*void_ffunc)(long x0, long x1, long x2, long x3,
long x4, long x5, long x6, long x7,
double d0, double d1, double d2, double d3,
double d4, double d5, double d6, double d7);
#if 0 /* this code is x86_64 legacy. */
/* Save current stack pointer and then push stack based arguments. */
asm volatile ("mov %%rsp, %0\n\t"
"sub %1, %%rsp\n\t"
"mov %2, %%rsi\n\t"
"mov %%rsp, %%rdi\n\t"
"rep\n\t"
"movsb\n\t"
: "=r" (stack_p)
: "c" (bufsize), "d" (buf)
: "%rdi", "%rsi", "%rsp");
asm volatile ("movsd (%0), %%xmm0\n\t"
"movsd 0x08(%0), %%xmm1\n\t"
"movsd 0x10(%0), %%xmm2\n\t"
"movsd 0x18(%0), %%xmm3\n\t"
"movsd 0x20(%0), %%xmm4\n\t"
"movsd 0x28(%0), %%xmm5\n\t"
"movsd 0x30(%0), %%xmm6\n\t"
"movsd 0x38(%0), %%xmm7\n\t"
:: "r" (registers->fp_registers)
: "%xmm0", "%xmm1", "%xmm2", "%xmm3",
"%xmm4", "%xmm5", "%xmm6", "%xmm7");
#endif
/* Registers r10 and r11 are mentionned in the clobber list of the asm
directives below in order to prevent GCC with -02 from using
either register to cache the value of stack_p across the function invocation.
Such a usage would be in violation of the x86_64 calling conventions. JCB
*/
if (return_type <= MKCL_FFI_OBJECT)
{
#if 0 /* this code is x86_64 legacy. */
asm volatile ("mov (%3), %%rdi\n\t"
"mov 0x08(%3), %%rsi\n\t"
"mov 0x10(%3), %%rdx\n\t"
"mov 0x18(%3), %%rcx\n\t"
"mov 0x20(%3), %%r8\n\t"
"mov 0x28(%3), %%r9\n\t"
"call *%%rbx\n\t"
: "=a" (fficall->output.ul)
: "b" (_f_ptr), "a" (registers->fp_registers_size),
"r" (registers->int_registers)
: "%rdx", "%rcx", "%rdi", "%rsi",
"%r8", "%r9", "r10", "r11");
#endif
{
mkcl_word args_on_stack[btop]; /* VLA */
for (; btop; btop--)
args_on_stack[btop] = args_buffer[btop]; /* copy overflow args to the tip of the stack. */
if (return_type <= MKCL_FFI_UNSIGNED_LONG) {
fficall->output.l
= ((dword_integral_ffunc) f_ptr) (regs->r[0], regs->r[1], regs->r[2], regs->r[3],
regs->r[4], regs->r[5], regs->r[6], regs->r[7],
regs->v[0].d, regs->v[1].d, regs->v[2].d, regs->v[3].d,
regs->v[4].d, regs->v[5].d, regs->v[6].d, regs->v[7].d);
} else if ((return_type == MKCL_FFI_POINTER_VOID)
|| (return_type == MKCL_FFI_CSTRING)
|| (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->r[4], regs->r[5], regs->r[6], regs->r[7],
regs->v[0].d, regs->v[1].d, regs->v[2].d, regs->v[3].d,
regs->v[4].d, regs->v[5].d, regs->v[6].d, regs->v[7].d);
} else if (return_type == MKCL_FFI_FLOAT) {
fficall->output.f
= ((float_ffunc) f_ptr) (regs->r[0], regs->r[1], regs->r[2], regs->r[3],
regs->r[4], regs->r[5], regs->r[6], regs->r[7],
regs->v[0].d, regs->v[1].d, regs->v[2].d, regs->v[3].d,
regs->v[4].d, regs->v[5].d, regs->v[6].d, regs->v[7].d);
} else if (return_type == MKCL_FFI_DOUBLE) {
fficall->output.d
= ((double_ffunc) f_ptr) (regs->r[0], regs->r[1], regs->r[2], regs->r[3],
regs->r[4], regs->r[5], regs->r[6], regs->r[7],
regs->v[0].d, regs->v[1].d, regs->v[2].d, regs->v[3].d,
regs->v[4].d, regs->v[5].d, regs->v[6].d, regs->v[7].d);
} else if (return_type == MKCL_FFI_LONG_DOUBLE) {
fficall->output.ld
= ((long_double_ffunc) f_ptr) (regs->r[0], regs->r[1], regs->r[2], regs->r[3],
regs->r[4], regs->r[5], regs->r[6], regs->r[7],
regs->v[0].d, regs->v[1].d, regs->v[2].d, regs->v[3].d,
regs->v[4].d, regs->v[5].d, regs->v[6].d, regs->v[7].d);
}
else if (return_type == MKCL_FFI_FLOAT)
{
#if 0 /* this code is x86_64 legacy. */
asm volatile ("mov (%2), %%rdi\n\t"
"mov 0x08(%2), %%rsi\n\t"
"mov 0x10(%2), %%rdx\n\t"
"mov 0x18(%2), %%rcx\n\t"
"mov 0x20(%2), %%r8\n\t"
"mov 0x28(%2), %%r9\n\t"
"call *%%rbx\n\t"
: /* see next asm */
: "b" (_f_ptr),
"a" (registers->fp_registers_size),
"r" (registers->int_registers)
: "%rdx", "%rcx", "%rdi", "%rsi",
"%r8", "%r9", "r10", "r11", "%xmm0");
asm volatile ("movss %%xmm0, (%0)\n\t"
:: "r" (&(fficall->output.f)));
#endif
else if (return_type == MKCL_FFI_VOID) {
((void_ffunc) f_ptr) (regs->r[0], regs->r[1], regs->r[2], regs->r[3],
regs->r[4], regs->r[5], regs->r[6], regs->r[7],
regs->v[0].d, regs->v[1].d, regs->v[2].d, regs->v[3].d,
regs->v[4].d, regs->v[5].d, regs->v[6].d, regs->v[7].d);
}
else if (return_type == MKCL_FFI_DOUBLE)
{
#if 0 /* this code is x86_64 legacy. */
asm volatile ("mov (%2), %%rdi\n\t"
"mov 0x08(%2), %%rsi\n\t"
"mov 0x10(%2), %%rdx\n\t"
"mov 0x18(%2), %%rcx\n\t"
"mov 0x20(%2), %%r8\n\t"
"mov 0x28(%2), %%r9\n\t"
"call *%%rbx\n\t"
: /* see next asm */
: "b" (_f_ptr),
"a" (registers->fp_registers_size),
"r" (registers->int_registers)
: "%rdx", "%rcx", "%rdi", "%rsi",
"%r8", "%r9", "r10", "r11", "%xmm0");
asm volatile ("movsd %%xmm0, (%0)\n\t"
:: "r" (&(fficall->output.d)));
#endif
else if ((return_type == MKCL_FFI_LONG_LONG)
|| (return_type == MKCL_FFI_UNSIGNED_LONG_LONG)) {
fficall->output.ll
= ((long_long_ffunc) f_ptr) (regs->r[0], regs->r[1], regs->r[2], regs->r[3],
regs->r[4], regs->r[5], regs->r[6], regs->r[7],
regs->v[0].d, regs->v[1].d, regs->v[2].d, regs->v[3].d,
regs->v[4].d, regs->v[5].d, regs->v[6].d, regs->v[7].d);
}
else if (return_type == MKCL_FFI_VOID)
{
#if 0 /* this code is x86_64 legacy. */
asm volatile ("mov (%2), %%rdi\n\t"
"mov 0x08(%2), %%rsi\n\t"
"mov 0x10(%2), %%rdx\n\t"
"mov 0x18(%2), %%rcx\n\t"
"mov 0x20(%2), %%r8\n\t"
"mov 0x28(%2), %%r9\n\t"
"call *%%rbx\n\t"
: /* no output */
: "b" (_f_ptr),
"a" (registers->fp_registers_size),
"r" (registers->int_registers)
: "%rdx", "%rcx", "%rdi", "%rsi",
"%r8", "%r9", "r10", "r11");
#endif
else {
mkcl_FEerror(env, "Unknown C function return type", 0);
}
else
mkcl_FEerror(env, "Invalid argument type for a C function", 0);
#if 0 /* this code is x86_64 legacy. */
/* restore saved stack pointer */
asm volatile ("mov %0,%%rsp" :: "r" (stack_p): "%rsp");
#endif
}
}
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 unsigned long
mkcl_dynamic_callback_execute(long i1, long i2, long i3, long i4, long i5, long i6,
double f1, double f2, double f3, double f4,
double f5, double f6, double f7, double f8,
static union mkcl_ffi_values
mkcl_dynamic_callback_execute(long x0, long x1, long x2, long x3,
long x4, long x5, long x6, long x7,
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 size, i_reg_index, f_reg_index;
union mkcl_ffi_values output;
enum mkcl_ffi_tag tag;
long i_reg[MAX_INT_REGISTERS];
double f_reg[MAX_FP_REGISTERS];
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);
struct mkcl_fficall_reg registers;
mkcl_fficall_prepare_extra(env, &registers);
registers.r[0] = x0;
registers.r[1] = x1;
registers.r[2] = x2;
registers.r[3] = x3;
registers.r[4] = x4;
registers.r[5] = x5;
registers.r[6] = x6;
registers.r[7] = x7;
registers.v[0].d = d0;
registers.v[1].d = d1;
registers.v[2].d = d2;
registers.v[3].d = d3;
registers.v[4].d = d4;
registers.v[5].d = d5;
registers.v[6].d = d6;
registers.v[7].d = d7;
arg_buffer += sizeof(long); /* Skip saved LR (a.k.a.: return address) */
arg_buffer += sizeof(long); /* Skip saved r4 */
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.
Returning -1 is just to please the compiler. */
{ errno = ENOMEM; return -1; }
/* In the normal case we always set errno = 0, so this is clearly an error situation. */
{ 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);
i_reg_index = f_reg_index = 0;
i_reg[0] = i1;
i_reg[1] = i2;
i_reg[2] = i3;
i_reg[3] = i4;
i_reg[4] = i5;
i_reg[5] = i6;
f_reg[0] = f1;
f_reg[1] = f2;
f_reg[2] = f3;
f_reg[3] = f4;
f_reg[4] = f5;
f_reg[5] = f6;
f_reg[6] = f7;
f_reg[7] = f8;
arg_buffer += 2*sizeof(void*); /* Skip return address and base pointer */
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)));
if (tag <= MKCL_FFI_OBJECT) {
if (i_reg_index < MAX_INT_REGISTERS)
result = mkcl_foreign_ref_elt(env, &i_reg[i_reg_index++], tag);
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)));
if ((tag == MKCL_FFI_LONG_LONG) || (tag == MKCL_FFI_UNSIGNED_LONG_LONG))
{
if (registers.core_register_count < (MAX_CORE_REGISTERS - 1)) {
result = mkcl_foreign_ref_elt(env, &registers.r[registers.core_register_count], tag);
registers.core_register_count += 2;
} else
goto ARG_FROM_STACK;
}
else if (tag <= MKCL_FFI_OBJECT) /* word sized integral */
if (registers.core_register_count < MAX_CORE_REGISTERS)
result = mkcl_foreign_ref_elt(env, &registers.r[registers.core_register_count++], tag);
else
goto ARG_FROM_STACK;
} else if (tag <= MKCL_FFI_DOUBLE) {
if (f_reg_index < MAX_FP_REGISTERS)
result = mkcl_foreign_ref_elt(env, &f_reg[f_reg_index++], tag);
else
else if (tag == MKCL_FFI_FLOAT)
if (registers.vfp_register_least_unallocated < MAX_VFP_REGISTERS) {
int i = registers.vfp_register_least_unallocated;
result = mkcl_foreign_ref_elt(env, &registers.v[i].s, tag);
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
goto ARG_FROM_STACK;
} else {
else if ((tag == MKCL_FFI_DOUBLE) || (tag == MKCL_FFI_LONG_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) {
result = mkcl_foreign_ref_elt(env, &registers.v[least_unallocated_pair / 2].d, tag);
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 */
goto ARG_FROM_STACK;
}
} else {
registers.vfp_register_least_unallocated = MAX_VFP_REGISTERS; /* this ends back-filling */
goto ARG_FROM_STACK;
}
else if (tag >= MKCL_FFI_VOID)
mkcl_FEerror(env, "Invalid C function callback argument type", 0);
else
ARG_FROM_STACK:
result = mkcl_foreign_ref_elt(env, arg_buffer, tag);
{
mkcl_index sp = (size + 0x7) & ~((mkcl_index) 0x7);
arg_buffer += (sp);
mkcl_index size_on_stack = (size + 0x07) & ~((mkcl_index) 0x07);
result = mkcl_foreign_ref_elt(env, arg_buffer, tag);
arg_buffer += size_on_stack;
}
}
mkcl_temp_stack_frame_push(env, frame, result);
}
if (imported_env)
{
mkcl_object thread = env->own_thread;
......@@ -319,6 +375,7 @@ mkcl_dynamic_callback_execute(long i1, long i2, long i3, long i4, long i5, long
mkcl_enable_interrupts(env);
result = mkcl_apply_from_temp_stack_frame(env, frame, fun);
mkcl_disable_interrupts(env);
mkcl_cleanup_thread_lisp_context(env);
} MKCL_CATCH_ALL_END;
......@@ -328,50 +385,132 @@ mkcl_dynamic_callback_execute(long i1, long i2, long i3, long i4, long i5, long
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;
{
unsigned long val = 0;
switch (tag) {
case MKCL_FFI_CHAR: val = output.c; break;
case MKCL_FFI_UNSIGNED_CHAR: val = output.uc; break;