Move foreign pointers off scm_words

* libguile/foreign.h: Give pointers a struct type.  Adapt to use it
internally.
* libguile/foreign.c: Allocate pointers with scm_allocate_tagged.

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);
 }

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);