-/* Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
SCM_SYMBOL (sym_unsigned_int, "unsigned-int");
SCM_SYMBOL (sym_unsigned_long, "unsigned-long");
SCM_SYMBOL (sym_size_t, "size_t");
+SCM_SYMBOL (sym_ssize_t, "ssize_t");
+SCM_SYMBOL (sym_ptrdiff_t, "ptrdiff_t");
/* that's for pointers, you know. */
SCM_SYMBOL (sym_asterisk, "*");
}
static void
-pointer_finalizer_trampoline (GC_PTR ptr, GC_PTR data)
+pointer_finalizer_trampoline (void *ptr, void *data)
{
scm_t_pointer_finalizer finalizer = data;
finalizer (SCM_POINTER_VALUE (PTR2SCM (ptr)));
}
#undef FUNC_NAME
+void *
+scm_to_pointer (SCM pointer)
+#define FUNC_NAME "scm_to_pointer"
+{
+ SCM_VALIDATE_POINTER (1, pointer);
+ return SCM_POINTER_VALUE (pointer);
+}
+#undef FUNC_NAME
+
SCM
scm_from_pointer (void *ptr, scm_t_pointer_finalizer finalizer)
{
ret = scm_cell (scm_tc7_pointer, (scm_t_bits) ptr);
if (finalizer)
- {
- /* Register a finalizer for the newly created instance. */
- GC_finalization_proc prev_finalizer;
- GC_PTR prev_finalizer_data;
- GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret),
- pointer_finalizer_trampoline,
- finalizer,
- &prev_finalizer,
- &prev_finalizer_data);
- }
+ scm_i_set_finalizer (SCM2PTR (ret), pointer_finalizer_trampoline,
+ finalizer);
}
return ret;
blen = scm_to_size_t (len);
- ret = scm_c_take_typed_bytevector (ptr + boffset, blen, btype);
+ ret = scm_c_take_typed_bytevector ((signed char *) ptr + boffset,
+ blen, btype);
register_weak_reference (ret, pointer);
return ret;
}
#define FUNC_NAME s_scm_bytevector_to_pointer
{
SCM ret;
- scm_t_int8 *ptr;
+ signed char *ptr;
size_t boffset;
SCM_VALIDATE_BYTEVECTOR (1, bv);
"Scheme. If you need a Scheme finalizer, use guardians.")
#define FUNC_NAME s_scm_set_pointer_finalizer_x
{
- void *c_finalizer;
- GC_finalization_proc prev_finalizer;
- GC_PTR prev_finalizer_data;
-
SCM_VALIDATE_POINTER (1, pointer);
SCM_VALIDATE_POINTER (2, finalizer);
- c_finalizer = SCM_POINTER_VALUE (finalizer);
-
- SCM_SET_CELL_WORD_0 (pointer, SCM_CELL_WORD_0 (pointer) | (1 << 16UL));
-
- GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (pointer),
- pointer_finalizer_trampoline,
- c_finalizer,
- &prev_finalizer,
- &prev_finalizer_data);
+ scm_i_add_finalizer (SCM2PTR (pointer), pointer_finalizer_trampoline,
+ SCM_POINTER_VALUE (finalizer));
return SCM_UNSPECIFIED;
}
ret = scm_from_pointer
(scm_to_stringn (string, NULL, enc,
- scm_i_get_conversion_strategy (SCM_BOOL_F)),
+ scm_i_default_port_conversion_handler ()),
free);
scm_dynwind_end ();
scm_dynwind_free (enc);
ret = scm_from_stringn (SCM_POINTER_VALUE (pointer), len, enc,
- scm_i_get_conversion_strategy (SCM_BOOL_F));
+ scm_i_default_port_conversion_handler ());
scm_dynwind_end ();
switch (SCM_I_INUM (type))
{
case SCM_FOREIGN_TYPE_FLOAT:
- return scm_from_size_t (alignof (float));
+ return scm_from_size_t (alignof_type (float));
case SCM_FOREIGN_TYPE_DOUBLE:
- return scm_from_size_t (alignof (double));
+ return scm_from_size_t (alignof_type (double));
case SCM_FOREIGN_TYPE_UINT8:
- return scm_from_size_t (alignof (scm_t_uint8));
+ return scm_from_size_t (alignof_type (scm_t_uint8));
case SCM_FOREIGN_TYPE_INT8:
- return scm_from_size_t (alignof (scm_t_int8));
+ return scm_from_size_t (alignof_type (scm_t_int8));
case SCM_FOREIGN_TYPE_UINT16:
- return scm_from_size_t (alignof (scm_t_uint16));
+ return scm_from_size_t (alignof_type (scm_t_uint16));
case SCM_FOREIGN_TYPE_INT16:
- return scm_from_size_t (alignof (scm_t_int16));
+ return scm_from_size_t (alignof_type (scm_t_int16));
case SCM_FOREIGN_TYPE_UINT32:
- return scm_from_size_t (alignof (scm_t_uint32));
+ return scm_from_size_t (alignof_type (scm_t_uint32));
case SCM_FOREIGN_TYPE_INT32:
- return scm_from_size_t (alignof (scm_t_int32));
+ return scm_from_size_t (alignof_type (scm_t_int32));
case SCM_FOREIGN_TYPE_UINT64:
- return scm_from_size_t (alignof (scm_t_uint64));
+ return scm_from_size_t (alignof_type (scm_t_uint64));
case SCM_FOREIGN_TYPE_INT64:
- return scm_from_size_t (alignof (scm_t_int64));
+ return scm_from_size_t (alignof_type (scm_t_int64));
default:
scm_wrong_type_arg (FUNC_NAME, 1, type);
}
}
else if (scm_is_eq (type, sym_asterisk))
/* a pointer */
- return scm_from_size_t (alignof (void*));
+ return scm_from_size_t (alignof_type (void*));
else if (scm_is_pair (type))
{
/* TYPE is a structure. Section 3-3 of the i386, x86_64, PowerPC,
/* then ffi_type pointers: one for each arg, one for each struct
element, and one for each struct (for null-termination) */
- cif_len = (ROUND_UP (cif_len, alignof(void*))
+ cif_len = (ROUND_UP (cif_len, alignof_type (void *))
+ (nargs + n_structs + n_struct_elts)*sizeof(void*));
/* then the ffi_type structs themselves, one per arg and struct element, and
one for the return val */
- cif_len = (ROUND_UP (cif_len, alignof(ffi_type))
+ cif_len = (ROUND_UP (cif_len, alignof_type (ffi_type))
+ (nargs + n_struct_elts + 1)*sizeof(ffi_type));
mem = scm_gc_malloc_pointerless (cif_len, "foreign");
cif = (ffi_cif *) mem;
/* reuse cif_len to walk through the mem */
- cif_len = ROUND_UP (sizeof (ffi_cif), alignof(void*));
+ cif_len = ROUND_UP (sizeof (ffi_cif), alignof_type (void *));
type_ptrs = (ffi_type**)(mem + cif_len);
cif_len = ROUND_UP (cif_len
+ (nargs + n_structs + n_struct_elts)*sizeof(void*),
- alignof(ffi_type));
+ alignof_type (ffi_type));
types = (ffi_type*)(mem + cif_len);
/* whew. now knit the pointers together. */
/* 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));
/* Set *LOC to the foreign representation of X with TYPE. */
static void
-unpack (const ffi_type *type, void *loc, SCM x)
+unpack (const ffi_type *type, void *loc, SCM x, int return_value_p)
#define FUNC_NAME "scm_i_foreign_call"
{
switch (type->type)
case FFI_TYPE_DOUBLE:
*(double *) loc = scm_to_double (x);
break;
+
+ /* For integer return values smaller than `int', libffi expects the
+ result in an `ffi_arg'-long buffer. */
+
case FFI_TYPE_UINT8:
- *(scm_t_uint8 *) loc = scm_to_uint8 (x);
+ if (return_value_p)
+ *(ffi_arg *) loc = scm_to_uint8 (x);
+ else
+ *(scm_t_uint8 *) loc = scm_to_uint8 (x);
break;
case FFI_TYPE_SINT8:
- *(scm_t_int8 *) loc = scm_to_int8 (x);
+ if (return_value_p)
+ *(ffi_arg *) loc = scm_to_int8 (x);
+ else
+ *(scm_t_int8 *) loc = scm_to_int8 (x);
break;
case FFI_TYPE_UINT16:
- *(scm_t_uint16 *) loc = scm_to_uint16 (x);
+ if (return_value_p)
+ *(ffi_arg *) loc = scm_to_uint16 (x);
+ else
+ *(scm_t_uint16 *) loc = scm_to_uint16 (x);
break;
case FFI_TYPE_SINT16:
- *(scm_t_int16 *) loc = scm_to_int16 (x);
+ if (return_value_p)
+ *(ffi_arg *) loc = scm_to_int16 (x);
+ else
+ *(scm_t_int16 *) loc = scm_to_int16 (x);
break;
case FFI_TYPE_UINT32:
- *(scm_t_uint32 *) loc = scm_to_uint32 (x);
+ if (return_value_p)
+ *(ffi_arg *) loc = scm_to_uint32 (x);
+ else
+ *(scm_t_uint32 *) loc = scm_to_uint32 (x);
break;
case FFI_TYPE_SINT32:
- *(scm_t_int32 *) loc = scm_to_int32 (x);
+ if (return_value_p)
+ *(ffi_arg *) loc = scm_to_int32 (x);
+ else
+ *(scm_t_int32 *) loc = scm_to_int32 (x);
break;
case FFI_TYPE_UINT64:
*(scm_t_uint64 *) loc = scm_to_uint64 (x);
args[i] = (void *) ROUND_UP ((scm_t_uintptr) data + off,
cif->arg_types[i]->alignment);
assert ((scm_t_uintptr) args[i] % cif->arg_types[i]->alignment == 0);
- unpack (cif->arg_types[i], args[i], argv[i]);
+ unpack (cif->arg_types[i], args[i], argv[i], 0);
}
/* Prepare space for the return value. On some platforms, such as
result = scm_call_n (proc, argv, cif->nargs);
- unpack (cif->rtype, ret, result);
+ unpack (cif->rtype, ret, result, 1);
}
SCM_DEFINE (scm_procedure_to_pointer, "procedure->pointer", 3, 0, 0,
(SCM return_type, SCM proc, SCM arg_types),
- "Return a pointer to a C function of type @var{return-type}\n"
- "taking arguments of types @var{arg-types} (a list) and\n"
+ "Return a pointer to a C function of type @var{return_type}\n"
+ "taking arguments of types @var{arg_types} (a list) and\n"
"behaving as a proxy to procedure @var{proc}. Thus\n"
"@var{proc}'s arity, supported argument types, and return\n"
- "type should match @var{return-type} and @var{arg-types}.\n")
+ "type should match @var{return_type} and @var{arg_types}.\n")
#define FUNC_NAME s_scm_procedure_to_pointer
{
- SCM pointer;
+ SCM cif_pointer, pointer;
ffi_cif *cif;
ffi_status err;
void *closure, *executable;
SCM_MISC_ERROR ("`ffi_prep_closure_loc' failed", SCM_EOL);
}
+ /* CIF points to GC-managed memory and it should remain as long as
+ POINTER (see below) is live. Wrap it in a Scheme pointer to then
+ hold a weak reference on it. */
+ cif_pointer = scm_from_pointer (cif, NULL);
+
if (closure == executable)
- pointer = scm_from_pointer (executable, ffi_closure_free);
+ {
+ pointer = scm_from_pointer (executable, ffi_closure_free);
+ register_weak_reference (pointer,
+ scm_list_2 (proc, cif_pointer));
+ }
else
{
/* CLOSURE needs to be freed eventually. However, since
pointer = scm_from_pointer (executable, NULL);
friend = scm_from_pointer (closure, ffi_closure_free);
- register_weak_reference (pointer, friend);
+ register_weak_reference (pointer,
+ scm_list_3 (proc, cif_pointer, friend));
}
return pointer;
scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32)
#else
# error unsupported sizeof (size_t)
+#endif
+ );
+
+ scm_define (sym_ssize_t,
+#if SIZEOF_SIZE_T == 8
+ scm_from_uint8 (SCM_FOREIGN_TYPE_INT64)
+#elif SIZEOF_SIZE_T == 4
+ scm_from_uint8 (SCM_FOREIGN_TYPE_INT32)
+#else
+# error unsupported sizeof (ssize_t)
+#endif
+ );
+
+ scm_define (sym_ptrdiff_t,
+#if SCM_SIZEOF_SCM_T_PTRDIFF == 8
+ scm_from_uint8 (SCM_FOREIGN_TYPE_INT64)
+#elif SCM_SIZEOF_SCM_T_PTRDIFF == 4
+ scm_from_uint8 (SCM_FOREIGN_TYPE_INT32)
+#else
+# error unsupported sizeof (scm_t_ptrdiff)
#endif
);
HCoop / bpt / guile.git / blobdiff