static SCM pointer_weak_refs = SCM_BOOL_F;
-static scm_i_pthread_mutex_t weak_refs_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
static void
register_weak_reference (SCM from, SCM to)
{
- scm_i_pthread_mutex_lock (&weak_refs_lock);
- scm_hashq_set_x (pointer_weak_refs, from, to);
- scm_i_pthread_mutex_unlock (&weak_refs_lock);
+ scm_weak_table_putq_x (pointer_weak_refs, from, to);
}
static void
pointer_finalizer_trampoline (GC_PTR ptr, GC_PTR data)
{
scm_t_pointer_finalizer finalizer = data;
- finalizer (SCM_POINTER_VALUE (PTR2SCM (ptr)));
+ finalizer (SCM_POINTER_VALUE (SCM_PACK_POINTER (ptr)));
}
SCM_DEFINE (scm_pointer_p, "pointer?", 1, 0, 0,
/* 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),
+ GC_REGISTER_FINALIZER_NO_ORDER (SCM_HEAP_OBJECT_BASE (ret),
pointer_finalizer_trampoline,
finalizer,
&prev_finalizer,
SCM ret;
ret = scm_from_pointer ((void*) SCM_UNPACK (scm), NULL);
- if (SCM_NIMP (ret))
+ if (SCM_HEAP_OBJECT_P (ret))
register_weak_reference (ret, scm);
return ret;
SCM_SET_CELL_WORD_0 (pointer, SCM_CELL_WORD_0 (pointer) | (1 << 16UL));
- GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (pointer),
+ GC_REGISTER_FINALIZER_NO_ORDER (SCM_HEAP_OBJECT_BASE (pointer),
pointer_finalizer_trampoline,
c_finalizer,
&prev_finalizer,
void
scm_i_pointer_print (SCM pointer, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<pointer 0x", port);
+ scm_puts_unlocked ("#<pointer 0x", port);
scm_uintprint (scm_to_uintptr (scm_pointer_address (pointer)), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
\f
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. */
/* 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
size_t i;
SCM proc, *argv, result;
- proc = PTR2SCM (data);
+ proc = SCM_PACK_POINTER (data);
argv = alloca (cif->nargs * sizeof (*argv));
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,
"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;
closure = ffi_closure_alloc (sizeof (ffi_closure), &executable);
err = ffi_prep_closure_loc ((ffi_closure *) closure, cif,
- invoke_closure, SCM2PTR (proc),
+ invoke_closure, SCM_UNPACK_POINTER (proc),
executable);
if (err != FFI_OK)
{
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_init_foreign",
(scm_t_extension_init_func)scm_init_foreign,
NULL);
- pointer_weak_refs = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+ pointer_weak_refs = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
}
/*