/* Pre-generate trampolines for less than 10 arguments. */
#ifdef WORDS_BIGENDIAN
-#define OBJCODE_HEADER 0, 0, 0, 8, 0, 0, 0, 40
-#define META_HEADER 0, 0, 0, 32, 0, 0, 0, 0
+#define OBJCODE_HEADER(M) M (0), M (0), M (0), M (8), M (0), M (0), M (0), M (40)
+#define META_HEADER(M) M (0), M (0), M (0), M (32), M (0), M (0), M (0), M (0)
#else
-#define OBJCODE_HEADER 8, 0, 0, 0, 40, 0, 0, 0
-#define META_HEADER 32, 0, 0, 0, 0, 0, 0, 0
+#define OBJCODE_HEADER(M) M (8), M (0), M (0), M (0), M (40), M (0), M (0), M (0)
+#define META_HEADER(M) M (32), M (0), M (0), M (0), M (0), M (0), M (0), M (0)
#endif
-#define CODE(nreq) \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */ \
- /* 3 */ scm_op_object_ref, 0, /* push the pair with the cif and the function pointer */ \
- /* 5 */ scm_op_foreign_call, nreq, /* and call (will return value as well) */ \
- /* 7 */ scm_op_nop, \
- /* 8 */ META (3, 7, nreq)
-
-#define META(start, end, nreq) \
- META_HEADER, \
- /* 0 */ scm_op_make_eol, /* bindings */ \
- /* 1 */ scm_op_make_eol, /* sources */ \
- /* 2 */ scm_op_make_int8, start, scm_op_make_int8, end, /* arity: from ip N to ip N */ \
- /* 6 */ scm_op_make_int8, nreq, /* the arity is N required args */ \
- /* 8 */ scm_op_list, 0, 3, /* make a list of those 3 vals */ \
- /* 11 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */ \
- /* 14 */ scm_op_load_symbol, 0, 0, 4, 'n', 'a', 'm', 'e', /* `name' */ \
- /* 22 */ scm_op_object_ref, 1, /* the name from the object table */ \
- /* 24 */ scm_op_cons, /* make a pair for the properties */ \
- /* 25 */ scm_op_list, 0, 4, /* pack bindings, sources, and arities into list */ \
- /* 28 */ scm_op_return, /* and return */ \
- /* 29 */ scm_op_nop, scm_op_nop, scm_op_nop \
+#define GEN_CODE(M, nreq) \
+ OBJCODE_HEADER (M), \
+ /* 0 */ M (scm_op_assert_nargs_ee), M (0), M (nreq), /* assert number of args */ \
+ /* 3 */ M (scm_op_object_ref), M (0), /* push the pair with the cif and the function pointer */ \
+ /* 5 */ M (scm_op_foreign_call), M (nreq), /* and call (will return value as well) */ \
+ /* 7 */ M (scm_op_nop), \
+ /* 8 */ META (M, 3, 7, nreq)
+
+#define META(M, start, end, nreq) \
+ META_HEADER (M), \
+ /* 0 */ M (scm_op_make_eol), /* bindings */ \
+ /* 1 */ M (scm_op_make_eol), /* sources */ \
+ /* 2 */ M (scm_op_make_int8), M (start), M (scm_op_make_int8), M (end), /* arity: from ip N to ip N */ \
+ /* 6 */ M (scm_op_make_int8), M (nreq), /* the arity is N required args */ \
+ /* 8 */ M (scm_op_list), M (0), M (3), /* make a list of those 3 vals */ \
+ /* 11 */ M (scm_op_list), M (0), M (1), /* and the arities will be a list of that one list */ \
+ /* 14 */ M (scm_op_load_symbol), M (0), M (0), M (4), M ('n'), M ('a'), M ('M'), M ('e'), /* `name' */ \
+ /* 22 */ M (scm_op_object_ref), M (1), /* the name from the object table */ \
+ /* 24 */ M (scm_op_cons), /* make a pair for the properties */ \
+ /* 25 */ M (scm_op_list), M (0), M (4), /* pack bindings, sources, and arities into list */ \
+ /* 28 */ M (scm_op_return), /* and return */ \
+ /* 29 */ M (scm_op_nop), M (scm_op_nop), M (scm_op_nop) \
/* 32 */
+#define M_STATIC(x) (x)
+#define CODE(nreq) GEN_CODE (M_STATIC, nreq)
+
static const struct
{
scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way */
}
};
-#undef CODE
+static SCM
+make_objcode_trampoline (unsigned int nargs)
+{
+ const int size = sizeof (struct scm_objcode) + 8
+ + sizeof (struct scm_objcode) + 32;
+ SCM bytecode = scm_c_make_bytevector (size);
+ scm_t_uint8 *bytes = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (bytecode);
+ int i = 0;
+
+#define M_DYNAMIC(x) (bytes[i++] = (x))
+ GEN_CODE (M_DYNAMIC, nargs);
+#undef M_DYNAMIC
+
+ if (i != size)
+ scm_syserror ("make_objcode_trampoline");
+ return scm_bytecode_to_native_objcode (bytecode);
+}
+
+#undef GEN_CODE
#undef META
+#undef M_STATIC
+#undef CODE
#undef OBJCODE_HEADER
#undef META_HEADER
SCM_PACK (objcode_cells.cells+18),
};
+static SCM large_objcode_trampolines = SCM_UNDEFINED;
+static scm_i_pthread_mutex_t large_objcode_trampolines_mutex =
+ SCM_I_PTHREAD_MUTEX_INITIALIZER;
+
static SCM
-cif_to_procedure (SCM cif, SCM func_ptr)
+get_objcode_trampoline (unsigned int nargs)
{
- ffi_cif *c_cif;
- unsigned int nargs;
- SCM objcode, table, ret;
-
- c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif);
- nargs = c_cif->nargs;
+ SCM objcode;
if (nargs < 10)
objcode = objcode_trampolines[nargs];
+ else if (nargs < 128)
+ {
+ scm_i_scm_pthread_mutex_lock (&large_objcode_trampolines_mutex);
+ if (SCM_UNBNDP (large_objcode_trampolines))
+ large_objcode_trampolines = scm_c_make_vector (128, SCM_UNDEFINED);
+ objcode = scm_c_vector_ref (large_objcode_trampolines, nargs);
+ if (SCM_UNBNDP (objcode))
+ scm_c_vector_set_x (large_objcode_trampolines, nargs,
+ objcode = make_objcode_trampoline (nargs));
+ scm_i_pthread_mutex_unlock (&large_objcode_trampolines_mutex);
+ }
else
- scm_misc_error ("make-foreign-function", "args >= 10 currently unimplemented",
+ scm_misc_error ("make-foreign-function", "args >= 128 currently unimplemented",
SCM_EOL);
+
+ return objcode;
+}
+
+static SCM
+cif_to_procedure (SCM cif, SCM func_ptr)
+{
+ ffi_cif *c_cif;
+ SCM objcode, table, ret;
+
+ c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif);
+ objcode = get_objcode_trampoline (c_cif->nargs);
table = scm_c_make_vector (2, SCM_UNDEFINED);
SCM_SIMPLE_VECTOR_SET (table, 0, scm_cons (cif, func_ptr));
HCoop / bpt / guile.git / blobdiff