diff --git a/libguile/foreign.c b/libguile/foreign.c index a7482ba74..2ce9a1d4f 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -120,64 +120,58 @@ static SCM cif_to_procedure (SCM cif, SCM func_ptr, int with_errno); the object to stay alive as long as the derived pointer is alive. Storing the object in a slot of the derived pointer will allow for this. */ -static SCM -make_pointer (uintptr_t addr, size_t extra_word_count) +static struct scm_pointer * +make_pointer (uintptr_t addr, size_t gc_object_count) { - SCM ret = scm_words (scm_tc7_pointer | (extra_word_count << 16), - extra_word_count + 2); - SCM_SET_CELL_WORD_1 (ret, addr); + struct scm_pointer *ret = scm_allocate_tagged + (SCM_I_CURRENT_THREAD, sizeof (*ret) + gc_object_count * sizeof (SCM)); + + ret->tag_and_size = scm_tc7_pointer | (gc_object_count << 16); + ret->address = addr; + return ret; } -static size_t -pointer_extra_word_count (SCM ptr) -{ - if (!SCM_POINTER_P (ptr)) - abort (); - - return SCM_CELL_WORD_0 (ptr) >> 16; -} - static void -set_pointer_extra_word (SCM ptr, size_t idx, SCM val) +pointer_init_gc_object (struct scm_pointer *ptr, size_t idx, SCM val) { - if (!(idx < pointer_extra_word_count (ptr))) + if (!(idx < scm_pointer_gc_object_count (ptr))) abort (); - SCM_SET_CELL_OBJECT (ptr, idx + 2, val); + ptr->gc_objects[idx] = val; } static SCM make_pointer_0 (uintptr_t addr) { if (!addr) abort (); - return make_pointer (addr, 0); + return scm_i_from_pointer (make_pointer (addr, 0)); } static SCM make_pointer_1 (uintptr_t addr, SCM obj) { if (!addr) abort (); - SCM ret = make_pointer (addr, 1); - set_pointer_extra_word (ret, 0, obj); - return ret; + struct scm_pointer *ret = make_pointer (addr, 1); + pointer_init_gc_object (ret, 0, obj); + return scm_i_from_pointer (ret); } static SCM make_pointer_3 (uintptr_t addr, SCM obj0, SCM obj1, SCM obj2) { if (!addr) abort (); - SCM ret = make_pointer (addr, 3); - set_pointer_extra_word (ret, 0, obj0); - set_pointer_extra_word (ret, 1, obj1); - set_pointer_extra_word (ret, 2, obj2); - return ret; + struct scm_pointer *ret = make_pointer (addr, 3); + pointer_init_gc_object (ret, 0, obj0); + pointer_init_gc_object (ret, 1, obj1); + pointer_init_gc_object (ret, 2, obj2); + return scm_i_from_pointer (ret); } static void attach_finalizer (SCM ptr, SCM finalizer) { - if (!SCM_POINTER_P (finalizer)) + if (!scm_is_pointer (finalizer)) abort (); scm_i_add_pointer_finalizer (SCM_I_CURRENT_THREAD, ptr, finalizer); } @@ -1416,7 +1410,7 @@ scm_register_foreign (void) "scm_init_foreign", (scm_t_extension_init_func)scm_init_foreign, NULL); - null_pointer = make_pointer (0, 0); + null_pointer = scm_i_from_pointer (make_pointer (0, 0)); free_pointer = make_pointer_0 ((uintptr_t) free); ffi_closure_free_pointer = make_pointer_0 ((uintptr_t) ffi_closure_free); } diff --git a/libguile/foreign.h b/libguile/foreign.h index 0f5b2fef5..02b37d179 100644 --- a/libguile/foreign.h +++ b/libguile/foreign.h @@ -52,11 +52,59 @@ typedef enum scm_t_foreign_type scm_t_foreign_type; typedef void (*scm_t_pointer_finalizer) (void *); -#define SCM_POINTER_P(x) (SCM_HAS_TYP7 (x, scm_tc7_pointer)) +struct scm_pointer +{ + scm_t_bits tag_and_size; + uintptr_t address; + + /* Pointers can be allocated with a number of extra tail words. These + are useful when you have a pointer derived from an object; you need + the object to stay alive as long as the derived pointer is alive. + Storing the object in a slot of the derived pointer will allow for + this. */ + SCM gc_objects[]; +}; + +static inline int +scm_is_pointer (SCM x) +{ + return SCM_HAS_TYP7 (x, scm_tc7_pointer); +} + +// Most of these SCM-to-C-struct / C-struct-to-SCM functions are named +// "scm_to_foo" / "scm_from_foo", but here in the FFI we run afoul of +// the already-existing, already-well-named scm_to_pointer and +// scm_from_pointer. Let's just prefix with "scm_i_" instead. +static inline struct scm_pointer * +scm_i_to_pointer (SCM x) +{ + if (!scm_is_pointer (x)) + abort (); + return (struct scm_pointer *) SCM_UNPACK_POINTER (x); +} + +static inline SCM +scm_i_from_pointer (struct scm_pointer *x) +{ + return SCM_PACK_POINTER (x); +} + +static inline void* +scm_pointer_value (struct scm_pointer *p) +{ + return (void *) p->address; +} + +static inline size_t +scm_pointer_gc_object_count (struct scm_pointer *p) +{ + return p->tag_and_size >> 16; +} + +#define SCM_POINTER_P(x) (scm_is_pointer (x)) #define SCM_VALIDATE_POINTER(pos, x) \ SCM_MAKE_VALIDATE (pos, x, POINTER_P) -#define SCM_POINTER_VALUE(x) \ - ((void *) SCM_CELL_WORD_1 (x)) +#define SCM_POINTER_VALUE(x) (scm_pointer_value (scm_i_to_pointer (x))) SCM_API void *scm_to_pointer (SCM pointer); SCM_API SCM scm_from_pointer (void *, scm_t_pointer_finalizer);