diff options
author | Andy Wingo <wingo@pobox.com> | 2010-01-18 11:42:35 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-01-26 22:56:41 +0100 |
commit | 52fd9639fdeee068434342e1bdb8693b05ecac5c (patch) | |
tree | 9d8ab132c65a07ce2c2b102ae66682df5085d977 /libguile/foreign.c | |
parent | 75c242a256c273ab0690397df4277d44f01946e6 (diff) | |
download | guile-52fd9639fdeee068434342e1bdb8693b05ecac5c.tar.gz |
foreign.h presents a more pointer-centric interface
* libguile/foreign.c:
* libguile/foreign.h: Rework interface to be more pointer-centric.
Details are:
(SCM_FOREIGN_TYPE_STRUCT, SCM_FOREIGN_TYPE_POINTER): Removed; now the
pointer in a foreign is first-class. If it points to a native type
like uint32, then it still has a tag; but if it points to something
else, like a struct or a pointer or something, then its type is VOID
(i.e., void*).
(SCM_FOREIGN_POINTER): Rename from SCM_FOREIGN_OBJECT.
(SCM_FOREIGN_VALUE_REF, SCM_FOREIGN_VALUE_SET): Rename from
SCM_FOREIGN_OBJECT_REF and SCM_FOREIGN_OBJECT_SET, to indicate that
they only work with value types.
(SCM_FOREIGN_HAS_FINALIZER): Reserve a bit to indicate if the foreign
pointer in question has a finalizer registered.
(SCM_FOREIGN_LEN): For void* pointers, optionally store the length in
bytes of the associated memory region.
(SCM_FOREIGN_VALUE_P): Rename from SCM_FOREIGN_SIMPLE_P.
(SCM_VALIDATE_FOREIGN_VALUE): Rename from SCM_VALIDATE_FOREIGN_SIMPLE.
(scm_take_foreign_pointer): Rename from scm_c_take_foreign. Remove
scm_c_from_foreign.
(scm_foreign_type): New accessor.
(scm_foreign_ref, scm_foreign_set_x): Take some optional args, used
when dereferencing void pointers.
* libguile/dynl.h:
* libguile/dynl.c (scm_dynamic_pointer): New function, used by
scm_dynamic_func. Adapt code to foreign.h changes.
* libguile/goops.c (scm_enable_primitive_generic_x)
(scm_set_primitive_generic_x): Use the SCM_SET_SUBR_GENERIC macro.
* libguile/gsubr.c (create_gsubr): Adapt to API change.
* libguile/gsubr.h (SCM_SUBRF, SCM_SUBR_GENERIC): Store the pointer
directly, not indirected.
* libguile/snarf.h (SCM_DEFINE, SCM_IMMUTABLE_FOREIGN): Store subr
pointers directly. Adapt to SCM_FOREIGN_TYPE_VOID change.
* libguile/vm-i-system.c (subr-call): Access the void* directly.
Diffstat (limited to 'libguile/foreign.c')
-rw-r--r-- | libguile/foreign.c | 268 |
1 files changed, 151 insertions, 117 deletions
diff --git a/libguile/foreign.c b/libguile/foreign.c index 4a4b2181a..ec76a00aa 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -26,52 +26,29 @@ -static size_t -sizeof_type (scm_t_foreign_type type) -{ - switch (type) - { - case SCM_FOREIGN_TYPE_VOID: abort (); - case SCM_FOREIGN_TYPE_FLOAT: return sizeof(float); - case SCM_FOREIGN_TYPE_DOUBLE: return sizeof(double); - case SCM_FOREIGN_TYPE_UINT8: return sizeof(scm_t_uint8); - case SCM_FOREIGN_TYPE_INT8: return sizeof(scm_t_int8); - case SCM_FOREIGN_TYPE_UINT16: return sizeof(scm_t_uint16); - case SCM_FOREIGN_TYPE_INT16: return sizeof(scm_t_int16); - case SCM_FOREIGN_TYPE_UINT32: return sizeof(scm_t_uint32); - case SCM_FOREIGN_TYPE_INT32: return sizeof(scm_t_int32); - case SCM_FOREIGN_TYPE_UINT64: return sizeof(scm_t_uint64); - case SCM_FOREIGN_TYPE_INT64: return sizeof(scm_t_int64); - case SCM_FOREIGN_TYPE_STRUCT: abort (); - case SCM_FOREIGN_TYPE_POINTER: return sizeof(void*); - default: abort (); - } -} - - static void foreign_finalizer_trampoline (GC_PTR ptr, GC_PTR data) { scm_t_foreign_finalizer finalizer = data; - finalizer (SCM_FOREIGN_OBJECT (PTR2SCM (ptr), void*)); + finalizer (SCM_FOREIGN_POINTER (PTR2SCM (ptr), void)); } SCM -scm_c_from_foreign (scm_t_foreign_type type, void *val, size_t size, - scm_t_foreign_finalizer finalizer) +scm_take_foreign_pointer (scm_t_foreign_type type, void *ptr, size_t len, + scm_t_foreign_finalizer finalizer) { SCM ret; - if (!size) - size = sizeof_type (type); + scm_t_bits word0; - ret = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2 + size, + word0 = (scm_t_bits)(scm_tc7_foreign | (type<<8) + | (finalizer ? (1<<16) : 0) | (len<<17)); + if (SCM_UNLIKELY ((word0 >> 16) != len)) + scm_out_of_range ("scm_take_foreign_pointer", scm_from_size_t (len)); + + ret = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2, "foreign")); - SCM_SET_CELL_WORD_0 (ret, (scm_t_bits)(scm_tc7_foreign | (type<<8))); - - /* set SCM_FOREIGN_OBJECT to point to the third word of the object, which will - be 8-byte aligned. Then copy *val into that space. */ - SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2)); - memcpy (SCM_FOREIGN_OBJECT (ret, void), val, size); + SCM_SET_CELL_WORD_0 (ret, word0); + SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)ptr); if (finalizer) { @@ -88,124 +65,167 @@ scm_c_from_foreign (scm_t_foreign_type type, void *val, size_t size, return ret; } -SCM -scm_c_take_foreign (scm_t_foreign_type type, void *val, - scm_t_foreign_finalizer finalizer) +static void +keepalive (GC_PTR obj, GC_PTR data) { - SCM ret; - - ret = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2, - "foreign")); - SCM_SET_CELL_WORD_0 (ret, (scm_t_bits)(scm_tc7_foreign | (type<<8))); - /* Set SCM_FOREIGN_OBJECT to the given pointer. */ - SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)val); - - 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), - foreign_finalizer_trampoline, - finalizer, - &prev_finalizer, - &prev_finalizer_data); - } - - return ret; } -SCM_DEFINE (scm_foreign_ref, "foreign-ref", 1, 0, 0, - (SCM foreign), +SCM_DEFINE (scm_foreign_ref, "foreign-ref", 1, 3, 0, + (SCM foreign, SCM type, SCM offset, SCM len), "Reference the foreign value wrapped by @var{foreign}.\n\n" - "Note that only \"simple\" types may be referenced by this\n" - "function. See @code{foreign-struct-ref} or @code{foreign-pointer-ref}\n" - "for structs or pointers, respectively.") + "The value will be referenced according to its type.\n" + "If and only if the type of the foreign value is @code{void},\n" + "this function accepts optional @var{type} and @var{offset}\n" + "arguments, indicating that the pointer wrapped by\n" + "@var{foreign} should be incremented by @var{offset} bytes,\n" + "and treated as a pointer to a value of the given @var{type}.\n" + "@var{offset} defaults to 0.\n\n" + "If @var{type} itself is @code{void}, @var{len} will be used\n" + "to specify the size of the resulting @code{void} pointer.") #define FUNC_NAME s_scm_foreign_ref { - SCM_VALIDATE_FOREIGN_SIMPLE (1, foreign); + scm_t_foreign_type ftype; + scm_t_uint8 *ptr; - switch (SCM_FOREIGN_TYPE (foreign)) + SCM_VALIDATE_FOREIGN (1, foreign); + ptr = SCM_FOREIGN_POINTER (foreign, scm_t_uint8); + + ftype = SCM_FOREIGN_TYPE (foreign); + if (ftype == SCM_FOREIGN_TYPE_VOID) + { + if (SCM_UNBNDP (type)) + scm_error_num_args_subr (FUNC_NAME); + ftype = scm_to_unsigned_integer (type, 0, SCM_FOREIGN_TYPE_LAST); + if (!SCM_UNBNDP (offset)) + ptr += scm_to_ssize_t (offset); + } + else + { + if (!SCM_UNBNDP (type)) + scm_error_num_args_subr (FUNC_NAME); + } + + /* FIXME: is there a window in which we can see ptr but not foreign? */ + switch (ftype) { case SCM_FOREIGN_TYPE_FLOAT: - return scm_from_double (SCM_FOREIGN_OBJECT_REF (foreign, float)); + return scm_from_double (*(float*)ptr); case SCM_FOREIGN_TYPE_DOUBLE: - return scm_from_double (SCM_FOREIGN_OBJECT_REF (foreign, double)); + return scm_from_double (*(double*)ptr); case SCM_FOREIGN_TYPE_UINT8: - return scm_from_uint8 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint8)); + return scm_from_uint8 (*(scm_t_uint8*)ptr); case SCM_FOREIGN_TYPE_INT8: - return scm_from_int8 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int8)); + return scm_from_int8 (*(scm_t_int8*)ptr); case SCM_FOREIGN_TYPE_UINT16: - return scm_from_uint16 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint16)); + return scm_from_uint16 (*(scm_t_uint16*)ptr); case SCM_FOREIGN_TYPE_INT16: - return scm_from_int16 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int16)); + return scm_from_int16 (*(scm_t_int16*)ptr); case SCM_FOREIGN_TYPE_UINT32: - return scm_from_uint32 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint32)); + return scm_from_uint32 (*(scm_t_uint32*)ptr); case SCM_FOREIGN_TYPE_INT32: - return scm_from_int32 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int32)); + return scm_from_int32 (*(scm_t_int32*)ptr); case SCM_FOREIGN_TYPE_UINT64: - return scm_from_uint64 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint64)); + return scm_from_uint64 (*(scm_t_uint64*)ptr); case SCM_FOREIGN_TYPE_INT64: - return scm_from_int64 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int64)); + return scm_from_int64 (*(scm_t_int64*)ptr); case SCM_FOREIGN_TYPE_VOID: - case SCM_FOREIGN_TYPE_STRUCT: - case SCM_FOREIGN_TYPE_POINTER: + /* seems we're making a new pointer, woo */ + { + GC_finalization_proc prev_finalizer; + GC_PTR prev_finalizer_data; + SCM ret = scm_take_foreign_pointer + (ftype, ptr, SCM_UNBNDP (len) ? 0 : scm_to_size_t (len), NULL); + /* while the kid is alive, keep the parent alive */ + if (SCM_FOREIGN_HAS_FINALIZER (foreign)) + GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret), keepalive, foreign, + &prev_finalizer, &prev_finalizer_data); + return ret; + } default: - /* other cases should have been caught by the FOREIGN_SIMPLE check */ abort (); } } #undef FUNC_NAME -SCM_DEFINE (scm_foreign_set_x, "foreign-set!", 2, 0, 0, - (SCM foreign, SCM val), +SCM_DEFINE (scm_foreign_set_x, "foreign-set!", 2, 2, 0, + (SCM foreign, SCM val, SCM type, SCM offset), "Set the foreign value wrapped by @var{foreign}.\n\n" - "Note that only \"simple\" types may be set by this function.\n" - "See @code{foreign-struct-ref} or @code{foreign-pointer-ref} for\n" - "structs or pointers, respectively.") + "The value will be set according to its type.\n" + "If and only if the type of the foreign value is @code{void},\n" + "this function accepts optional @var{type} and @var{offset}\n" + "arguments, indicating that the pointer wrapped by\n" + "@var{foreign} should be incremented by @var{offset} bytes,\n" + "and treated as a pointer to a value of the given @var{type}.\n" + "@var{offset} defaults to 0.") #define FUNC_NAME s_scm_foreign_set_x { - SCM_VALIDATE_FOREIGN_SIMPLE (1, foreign); + scm_t_foreign_type ftype; + scm_t_uint8 *ptr; - switch (SCM_FOREIGN_TYPE (foreign)) + SCM_VALIDATE_FOREIGN (1, foreign); + ptr = SCM_FOREIGN_POINTER (foreign, scm_t_uint8); + + ftype = SCM_FOREIGN_TYPE (foreign); + if (ftype == SCM_FOREIGN_TYPE_VOID) + { + if (SCM_UNBNDP (type)) + scm_error_num_args_subr (FUNC_NAME); + ftype = scm_to_unsigned_integer (type, 0, SCM_FOREIGN_TYPE_LAST); + if (!SCM_UNBNDP (offset)) + ptr += scm_to_ssize_t (offset); + } + else + { + if (!SCM_UNBNDP (type)) + scm_error_num_args_subr (FUNC_NAME); + } + + /* FIXME: is there a window in which we can see ptr but not foreign? */ + switch (ftype) { case SCM_FOREIGN_TYPE_FLOAT: - SCM_FOREIGN_OBJECT_SET (foreign, float, scm_to_double (val)); + *(float*)ptr = scm_to_double (val); break; case SCM_FOREIGN_TYPE_DOUBLE: - SCM_FOREIGN_OBJECT_SET (foreign, double, scm_to_double (val)); + *(double*)ptr = scm_to_double (val); break; case SCM_FOREIGN_TYPE_UINT8: - SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint8, scm_to_uint8 (val)); + *(scm_t_uint8*)ptr = scm_to_uint8 (val); break; case SCM_FOREIGN_TYPE_INT8: - SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int8, scm_to_int8 (val)); + *(scm_t_int8*)ptr = scm_to_int8 (val); break; case SCM_FOREIGN_TYPE_UINT16: - SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint16, scm_to_uint16 (val)); + *(scm_t_uint16*)ptr = scm_to_uint16 (val); break; case SCM_FOREIGN_TYPE_INT16: - SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int16, scm_to_int16 (val)); + *(scm_t_int16*)ptr = scm_to_int16 (val); break; case SCM_FOREIGN_TYPE_UINT32: - SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint32, scm_to_uint32 (val)); + *(scm_t_uint32*)ptr = scm_to_uint32 (val); break; case SCM_FOREIGN_TYPE_INT32: - SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int32, scm_to_int32 (val)); + *(scm_t_int32*)ptr = scm_to_int32 (val); break; case SCM_FOREIGN_TYPE_UINT64: - SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint64, scm_to_uint64 (val)); + *(scm_t_uint64*)ptr = scm_to_uint64 (val); break; case SCM_FOREIGN_TYPE_INT64: - SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int64, scm_to_int64 (val)); + *(scm_t_int64*)ptr = scm_to_int64 (val); break; case SCM_FOREIGN_TYPE_VOID: - case SCM_FOREIGN_TYPE_STRUCT: - case SCM_FOREIGN_TYPE_POINTER: + SCM_VALIDATE_FOREIGN (2, val); + if (SCM_FOREIGN_HAS_FINALIZER (val)) + /* setting a pointer inside one foreign value to the pointer of another? + that is asking for trouble */ + scm_wrong_type_arg_msg (FUNC_NAME, 2, val, + "foreign value without finalizer"); + *(void**)ptr = SCM_FOREIGN_POINTER (val, void*); + break; default: - /* other cases should have been caught by the FOREIGN_SIMPLE check */ abort (); } + return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -216,55 +236,69 @@ scm_i_foreign_print (SCM foreign, SCM port, scm_print_state *pstate) scm_puts ("#<foreign ", port); switch (SCM_FOREIGN_TYPE (foreign)) { - case SCM_FOREIGN_TYPE_VOID: - abort (); case SCM_FOREIGN_TYPE_FLOAT: scm_puts ("float ", port); - scm_display (scm_foreign_ref (foreign), port); + scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED, + SCM_UNDEFINED), + port); break; case SCM_FOREIGN_TYPE_DOUBLE: scm_puts ("double ", port); - scm_display (scm_foreign_ref (foreign), port); + scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED, + SCM_UNDEFINED), + port); break; case SCM_FOREIGN_TYPE_UINT8: scm_puts ("uint8 ", port); - scm_display (scm_foreign_ref (foreign), port); + scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED, + SCM_UNDEFINED), + port); break; case SCM_FOREIGN_TYPE_INT8: scm_puts ("int8 ", port); - scm_display (scm_foreign_ref (foreign), port); + scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED, + SCM_UNDEFINED), + port); break; case SCM_FOREIGN_TYPE_UINT16: scm_puts ("uint16 ", port); - scm_display (scm_foreign_ref (foreign), port); + scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED, + SCM_UNDEFINED), + port); break; case SCM_FOREIGN_TYPE_INT16: scm_puts ("int16 ", port); - scm_display (scm_foreign_ref (foreign), port); + scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED, + SCM_UNDEFINED), + port); break; case SCM_FOREIGN_TYPE_UINT32: scm_puts ("uint32 ", port); - scm_display (scm_foreign_ref (foreign), port); + scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED, + SCM_UNDEFINED), + port); break; case SCM_FOREIGN_TYPE_INT32: scm_puts ("int32 ", port); - scm_display (scm_foreign_ref (foreign), port); + scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED, + SCM_UNDEFINED), + port); break; case SCM_FOREIGN_TYPE_UINT64: scm_puts ("uint64 ", port); - scm_display (scm_foreign_ref (foreign), port); + scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED, + SCM_UNDEFINED), + port); break; case SCM_FOREIGN_TYPE_INT64: scm_puts ("int64 ", port); - scm_display (scm_foreign_ref (foreign), port); + scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED, + SCM_UNDEFINED), + port); break; - case SCM_FOREIGN_TYPE_STRUCT: - scm_puts ("struct at 0x", port); - scm_uintprint (SCM_CELL_WORD_1 (foreign), 16, port); - break; - case SCM_FOREIGN_TYPE_POINTER: + case SCM_FOREIGN_TYPE_VOID: scm_puts ("pointer 0x", port); - scm_uintprint (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_bits), 16, port); + scm_uintprint ((scm_t_bits)SCM_FOREIGN_POINTER (foreign, void), 16, port); break; default: abort (); |