Rework pointer implementation to avoid weak tables

Instead of storing keep-alive edges in weak tables, just add extra
fields on pointer objects.

* libguile/foreign.c (make_pointer, pointer_extra_word_count)
(set_pointer_extra_word, make_pointer_0, make_pointer_1, make_pointer_3)
(attach_finalizer): New helpers.
(scm_make_pointer): Never attach finalizers on the null pointer object.
(scm_from_pointer): Likewise.
(scm_bytevector_to_pointer, scm_procedure_to_pointer): Store keep-alive
links in extra words.
(scm_init_foreign, scm_register_foreign): Rework init for null, free,
and ffi_closure_free pointers.

libguile/foreign.c

@@ -52,7 +52,6 @@
 #include "stacks.h"
 #include "symbols.h"
 #include "threads.h"
-#include "weak-table.h"
 #include "version.h"
 
 #include "foreign.h"
@@ -97,6 +96,8 @@ SCM_SYMBOL (sym_null_pointer_error, "null-pointer-error");
 
 /* The cell representing the null pointer.  */
 static SCM null_pointer;
+static SCM free_pointer;
+static SCM ffi_closure_free_pointer;
 
 
 /* Raise a null pointer dereference error.  */
@@ -111,13 +112,71 @@ null_pointer_error (const char *func_name)
 static SCM cif_to_procedure (SCM cif, SCM func_ptr, int with_errno);
 
 
-static SCM pointer_weak_refs = SCM_BOOL_F;
+/* 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.  */
+static SCM
+make_pointer (uintptr_t addr, size_t extra_word_count)
+{
+  SCM ret = scm_words (scm_tc7_pointer | (extra_word_count << 16),
+                       extra_word_count + 2);
+  SCM_SET_CELL_WORD_1 (ret, 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
-register_weak_reference (SCM from, SCM to)
+set_pointer_extra_word (SCM ptr, size_t idx, SCM val)
 {
-  scm_weak_table_putq_x (pointer_weak_refs, from, to);
+  if (!(idx < pointer_extra_word_count (ptr)))
+    abort ();
+
+  SCM_SET_CELL_OBJECT (ptr, idx + 2, val);
+}
+
+static SCM
+make_pointer_0 (uintptr_t addr)
+{
+  if (!addr) abort ();
+  return 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;
+}
+
+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;
+}
+
+static void
+attach_finalizer (SCM ptr, SCM finalizer)
+{
+  if (!SCM_POINTER_P (finalizer))
+    abort ();
+  scm_i_add_pointer_finalizer (SCM_I_CURRENT_THREAD, ptr, finalizer);
 }
 
 void
@@ -127,6 +186,9 @@ scm_i_finalize_pointer (struct scm_thread *thread, SCM ptr, SCM data)
   finalizer (SCM_POINTER_VALUE (ptr));
 }
 
+
+
+
 SCM_DEFINE (scm_pointer_p, "pointer?", 1, 0, 0,
 	    (SCM obj),
 	    "Return @code{#t} if @var{obj} is a pointer object, "
@@ -142,22 +204,22 @@ SCM_DEFINE (scm_make_pointer, "make-pointer", 1, 1, 0,
 	    "Return a foreign pointer object pointing to @var{address}. "
 	    "If @var{finalizer} is passed, it should be a pointer to a "
 	    "one-argument C function that will be called when the pointer "
-	    "object becomes unreachable.")
+	    "object becomes unreachable.  Finalizers will not be attached "
+            "to null pointers (foreign pointers whose value is 0).")
 #define FUNC_NAME s_scm_make_pointer
 {
-  void *c_finalizer;
-  uintptr_t c_address;
+  if (scm_is_eq (address, SCM_INUM0))
+    return null_pointer;
 
-  c_address = scm_to_uintptr_t (address);
-  if (SCM_UNBNDP (finalizer))
-    c_finalizer = NULL;
-  else
+  SCM ret = make_pointer_0 (scm_to_uintptr_t (address));
+
+  if (!SCM_UNBNDP (finalizer))
     {
       SCM_VALIDATE_POINTER (2, finalizer);
-      c_finalizer = SCM_POINTER_VALUE (finalizer);
+      attach_finalizer (ret, finalizer);
     }
 
-  return scm_from_pointer ((void *) c_address, c_finalizer);
+  return ret;
 }
 #undef FUNC_NAME
 
@@ -173,19 +235,13 @@ scm_to_pointer (SCM pointer)
 SCM
 scm_from_pointer (void *ptr, scm_t_pointer_finalizer finalizer)
 {
-  SCM ret;
+  if (ptr == NULL)
+    return null_pointer;
 
-  if (ptr == NULL && finalizer == NULL)
-    ret = null_pointer;
-  else
-    {
-      ret = scm_cell (scm_tc7_pointer, (scm_t_bits) ptr);
+  SCM ret = make_pointer_0 ((uintptr_t) ptr);
 
-      if (finalizer)
-        scm_i_add_pointer_finalizer (SCM_I_CURRENT_THREAD, ret,
-                                     scm_cell (scm_tc7_pointer,
-                                               (scm_t_bits) finalizer));
-    }
+  if (finalizer)
+    attach_finalizer (ret, make_pointer_0 ((uintptr_t) finalizer));
 
   return ret;
 }
@@ -219,13 +275,7 @@ SCM_DEFINE (scm_scm_to_pointer, "scm->pointer", 1, 0, 0,
             "of @var{scm}.")
 #define FUNC_NAME s_scm_scm_to_pointer
 {
-  SCM ret;
-
-  ret = scm_from_pointer ((void*) SCM_UNPACK (scm), NULL);
-  if (SCM_HEAP_OBJECT_P (ret))
-    register_weak_reference (ret, scm);
-
-  return ret;
+  return make_pointer_1 (SCM_UNPACK (scm), scm);
 }
 #undef FUNC_NAME
 
@@ -307,22 +357,15 @@ SCM_DEFINE (scm_bytevector_to_pointer, "bytevector->pointer", 1, 1, 0,
 	    "is passed.")
 #define FUNC_NAME s_scm_bytevector_to_pointer
 {
-  SCM ret;
-  signed char *ptr;
-  size_t boffset;
-
   SCM_VALIDATE_BYTEVECTOR (1, bv);
-  ptr = SCM_BYTEVECTOR_CONTENTS (bv);
+  signed char *ptr = SCM_BYTEVECTOR_CONTENTS (bv);
 
-  if (SCM_UNBNDP (offset))
-    boffset = 0;
-  else
-    boffset = scm_to_unsigned_integer (offset, 0,
-                                       SCM_BYTEVECTOR_LENGTH (bv) - 1);
+  size_t boffset = SCM_UNBNDP (offset)
+    ? 0
+    : scm_to_unsigned_integer (offset, 0,
+                               SCM_BYTEVECTOR_LENGTH (bv) - 1);
 
-  ret = scm_from_pointer (ptr + boffset, NULL);
-  register_weak_reference (ret, bv);
-  return ret;
+  return make_pointer_1 ((uintptr_t)(ptr + boffset), bv);
 }
 #undef FUNC_NAME
 
@@ -1196,51 +1239,26 @@ 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 cif_pointer, pointer;
-  ffi_cif *cif;
-  ffi_status err;
+  ffi_cif *cif = make_cif (return_type, arg_types, FUNC_NAME);
+
   void *closure, *executable;
-
-  cif = make_cif (return_type, arg_types, FUNC_NAME);
-
   closure = ffi_closure_alloc (sizeof (ffi_closure), &executable);
-  err = ffi_prep_closure_loc ((ffi_closure *) closure, cif,
-			      invoke_closure, SCM_UNPACK_POINTER (proc),
-			      executable);
+
+  ffi_status err = ffi_prep_closure_loc ((ffi_closure *) closure, cif,
+                                         invoke_closure,
+                                         SCM_UNPACK_POINTER (proc),
+                                         executable);
   if (err != FFI_OK)
     {
       ffi_closure_free (closure);
       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);
-      register_weak_reference (pointer,
-			       scm_list_2 (proc, cif_pointer));
-    }
-  else
-    {
-      /* CLOSURE needs to be freed eventually.  However, since
-	 `GC_all_interior_pointers' is disabled, we can't just register
-	 a finalizer for CLOSURE.  Instead, we create a pointer object
-	 for CLOSURE, with a finalizer, and register it as a weak
-	 reference of POINTER.  */
-      SCM friend;
-
-      pointer = scm_from_pointer (executable, NULL);
-      friend = scm_from_pointer (closure, ffi_closure_free);
-
-      register_weak_reference (pointer,
-			       scm_list_3 (proc, cif_pointer, friend));
-    }
-
-  return pointer;
+  SCM cif_pointer = make_pointer_0 ((uintptr_t) cif);
+  SCM closure_pointer = make_pointer_0 ((uintptr_t) closure);
+  attach_finalizer (closure_pointer, ffi_closure_free_pointer);
+  return make_pointer_3 ((uintptr_t) executable, proc, cif_pointer,
+                         closure_pointer);
 }
 #undef FUNC_NAME
 
@@ -1382,7 +1400,6 @@ scm_init_foreign (void)
 #endif
 	      );
 
-  null_pointer = scm_cell (scm_tc7_pointer, 0);
   scm_define (sym_null, null_pointer);
 }
 
@@ -1393,5 +1410,7 @@ scm_register_foreign (void)
                             "scm_init_foreign",
                             (scm_t_extension_init_func)scm_init_foreign,
                             NULL);
-  pointer_weak_refs = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
+  null_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);
 }