Moving ephemerals into the core. Using them as a weak table to store filenos,

and enforcing the invariant that there is only one fileno object with a given
number at a time.

include/chibi/sexp.h

@@ -161,6 +161,9 @@ enum sexp_types {
   SEXP_CPOINTER,
 #if SEXP_USE_AUTO_FORCE
   SEXP_PROMISE,
+#endif
+#if SEXP_USE_WEAK_REFERENCES
+  SEXP_EPHEMERON,
 #endif
   SEXP_NUM_CORE_TYPES
 };
@@ -679,6 +682,7 @@ sexp sexp_make_flonum(sexp ctx, double f);
 #define sexp_litp(x)        (sexp_check_tag(x, SEXP_LIT))
 #define sexp_contextp(x)    (sexp_check_tag(x, SEXP_CONTEXT))
 #define sexp_promisep(x)    (sexp_check_tag(x, SEXP_PROMISE))
+#define sexp_ephemeronp(x)  (sexp_check_tag(x, SEXP_EPHEMERON))
 
 #define sexp_applicablep(x) (sexp_procedurep(x) || sexp_opcodep(x))
 
@@ -1041,6 +1045,9 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 #define sexp_promise_donep(x) (sexp_field(x, promise, SEXP_PROMISE, donep))
 #define sexp_promise_value(x) (sexp_field(x, promise, SEXP_PROMISE, value))
 
+#define sexp_ephemeron_key(x)   (sexp_field(x, pair, SEXP_EPHEMERON, car))
+#define sexp_ephemeron_value(x) (sexp_field(x, pair, SEXP_EPHEMERON, cdr))
+
 #define sexp_context_env(x)      (sexp_field(x, context, SEXP_CONTEXT, env))
 #define sexp_context_stack(x)    (sexp_field(x, context, SEXP_CONTEXT, stack))
 #define sexp_context_parent(x)   (sexp_field(x, context, SEXP_CONTEXT, parent))
@@ -1196,7 +1203,6 @@ enum sexp_context_globals {
   SEXP_G_ABI_ERROR,             /* incompatible ABI loading library */
   SEXP_G_OPTIMIZATIONS,
   SEXP_G_SIGNAL_HANDLERS,
-  SEXP_G_FILE_DESCRIPTORS,
   SEXP_G_META_ENV,
   SEXP_G_MODULE_PATH,
   SEXP_G_QUOTE_SYMBOL,
@@ -1217,7 +1223,8 @@ enum sexp_context_globals {
   SEXP_G_FOLD_CASE_P,
 #endif
 #if SEXP_USE_WEAK_REFERENCES
-  SEXP_G_WEAK_REFERENCE_CACHE,
+  SEXP_G_FILE_DESCRIPTORS,
+  SEXP_G_NUM_FILE_DESCRIPTORS,
 #endif
 #if ! SEXP_USE_BOEHM
   SEXP_G_PRESERVATIVES,
@@ -1341,6 +1348,7 @@ SEXP_API sexp sexp_memq_op(sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp ls);
 SEXP_API sexp sexp_assq_op(sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp ls);
 SEXP_API sexp sexp_length_op(sexp ctx, sexp self, sexp_sint_t n, sexp ls);
 SEXP_API sexp sexp_c_string(sexp ctx, const char *str, sexp_sint_t slen);
+SEXP_API sexp sexp_make_ephemeron_op(sexp ctx, sexp self, sexp_sint_t n, sexp key, sexp value);
 SEXP_API sexp sexp_make_bytes_op(sexp ctx, sexp self, sexp_sint_t n, sexp len, sexp i);
 SEXP_API sexp sexp_make_string_op(sexp ctx, sexp self, sexp_sint_t n, sexp len, sexp ch);
 SEXP_API sexp sexp_substring_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp start, sexp end);
@@ -1533,6 +1541,7 @@ SEXP_API sexp sexp_finalize_c_type (sexp ctx, sexp self, sexp_sint_t n, sexp obj
 #define sexp_string_to_symbol(ctx, s) sexp_string_to_symbol_op(ctx, NULL, 1, s)
 #define sexp_string_to_number(ctx, s, b) sexp_string_to_number_op(ctx, NULL, 2, s, b)
 #define sexp_symbol_to_string(ctx, s) sexp_symbol_to_string_op(ctx, NULL, 1, s)
+#define sexp_make_ephemeron(ctx, k, v) sexp_make_ephemeron_op(ctx, NULL, 2, k, v)
 #define sexp_make_bytes(ctx, l, i) sexp_make_bytes_op(ctx, NULL, 2, l, i)
 #define sexp_make_string(ctx, l, c) sexp_make_string_op(ctx, NULL, 2, l, c)
 #define sexp_subbytes(ctx, a, b, c) sexp_subbytes_op(ctx, NULL, 3, a, b, c)

lib/chibi/weak.c

@@ -4,26 +4,15 @@
 
 #include <chibi/eval.h>
 
-#define sexp_ephemeron_key(x) sexp_slot_ref(x, 0)
-#define sexp_ephemeron_value(x) sexp_slot_ref(x, 1)
-
-#define sexp_weak_vector_p(x) sexp_check_tag(x, sexp_weak_vector_id)
-
-sexp sexp_make_ephemeron (sexp ctx, sexp self, sexp_sint_t n, sexp key, sexp value) {
-  sexp res = sexp_alloc_type(ctx, pair, sexp_unbox_fixnum(sexp_opcode_return_type(self)));
-  if (! sexp_exceptionp(res)) {
-    sexp_ephemeron_key(res) = key;
-    sexp_ephemeron_value(res) = value;
-  }
-  return res;
-}
-
 sexp sexp_ephemeron_brokenp_op (sexp ctx, sexp self, sexp_sint_t n, sexp eph) {
   if (! (sexp_pointerp(eph) && (sexp_pointer_tag(eph) == sexp_unbox_fixnum(sexp_opcode_arg1_type(self)))))
     return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), eph);
   return sexp_make_boolean(sexp_brokenp(eph));
 }
 
+#if 0
+#define sexp_weak_vector_p(x) sexp_check_tag(x, sexp_weak_vector_id)
+
 sexp sexp_make_weak_vector (sexp ctx, sexp self, sexp_sint_t n, sexp len) {
   sexp vec, *x;
   int i, clen = sexp_unbox_fixnum(len);
@@ -58,41 +47,34 @@ sexp sexp_weak_vector_set (sexp ctx, sexp self, sexp_sint_t n, sexp v, sexp k, s
   sexp_vector_set(v, k, x);
   return SEXP_VOID;
 }
+#endif
 
 sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
 #if 0
   sexp v;
   int sexp_weak_vector_id;
 #endif
-  int sexp_ephemeron_id;
   sexp_gc_var3(name, t, op);
   if (!(sexp_version_compatible(ctx, version, sexp_version)
         && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
     return SEXP_ABI_ERROR;
   sexp_gc_preserve3(ctx, name, t, op);
 
-  name = sexp_c_string(ctx, "Ephemeron", -1);
+  t = sexp_make_fixnum(SEXP_EPHEMERON);
-  t = sexp_register_simple_type(ctx, name, SEXP_FALSE, SEXP_TWO);
-  sexp_ephemeron_id = sexp_type_tag(t);
-  sexp_type_field_len_base(t) = 0;
-  sexp_type_weak_base(t) = sexp_type_field_base(t);
-  sexp_type_weak_len_base(t) = 1;
-  sexp_type_weak_len_extra(t) = 1;
-
   op = sexp_make_type_predicate(ctx, name=sexp_c_string(ctx,"ephemeron?",-1), t);
   sexp_env_define(ctx, env, name=sexp_intern(ctx, "ephemeron?", -1), op);
   op = sexp_make_getter(ctx, name=sexp_c_string(ctx, "ephemeron-key", -1), t, SEXP_ZERO);
   sexp_env_define(ctx, env, name=sexp_intern(ctx, "ephemeron-key", -1), op);
   op = sexp_make_getter(ctx, name=sexp_c_string(ctx, "ephemeron-value", -1), t, SEXP_ONE);
   sexp_env_define(ctx, env, name=sexp_intern(ctx, "ephemeron-value", -1), op);
-  op = sexp_define_foreign(ctx, env, "make-ephemeron", 2, sexp_make_ephemeron);
+  op = sexp_define_foreign(ctx, env, "make-ephemeron", 2, sexp_make_ephemeron_op);
   if (sexp_opcodep(op)) {
-    sexp_opcode_return_type(op) = sexp_make_fixnum(sexp_ephemeron_id);
+    sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_EPHEMERON);
   }
   op = sexp_define_foreign(ctx, env, "ephemeron-broken?", 1, sexp_ephemeron_brokenp_op);
   if (sexp_opcodep(op)) {
     sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT);
-    sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_ephemeron_id);
+    sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_EPHEMERON);
   }
 
 #if 0

sexp.c

@@ -233,6 +233,9 @@ static struct sexp_type_struct _sexp_type_specs[] = {
 #if SEXP_USE_AUTO_FORCE
   {SEXP_PROMISE, sexp_offsetof(promise, value), 1, 1, 0, 0, sexp_sizeof(promise), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Promise", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
 #endif
+#if SEXP_USE_WEAK_REFERENCES
+  {SEXP_EPHEMERON, sexp_offsetof(lit, value), 0, 0, 0, 0, sizeof(sexp), 0, 0, sexp_offsetof(lit, value), 1, 0, 0, 1, 0, (sexp)"Ephemeron", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+#endif
 };
 
 #define SEXP_INIT_NUM_TYPES (SEXP_NUM_CORE_TYPES*2)
@@ -394,6 +397,10 @@ void sexp_init_context_globals (sexp ctx) {
 #endif
 #if ! SEXP_USE_BOEHM
   sexp_global(ctx, SEXP_G_PRESERVATIVES) = SEXP_NULL;
+#endif
+#if SEXP_USE_WEAK_REFERENCES
+  sexp_global(ctx, SEXP_G_FILE_DESCRIPTORS) = SEXP_FALSE;
+  sexp_global(ctx, SEXP_G_NUM_FILE_DESCRIPTORS) = SEXP_ZERO;
 #endif
   sexp_global(ctx, SEXP_G_OOM_ERROR) = sexp_user_exception(ctx, SEXP_FALSE, "out of memory", SEXP_NULL);
   sexp_global(ctx, SEXP_G_OOS_ERROR) = sexp_user_exception(ctx, SEXP_FALSE, "out of stack space", SEXP_NULL);
@@ -1634,16 +1641,81 @@ sexp sexp_open_output_file_descriptor (sexp ctx, sexp self, sexp_sint_t n, sexp
 
 #endif  /* ! SEXP_USE_STRING_STREAMS */
 
+#if SEXP_USE_WEAK_REFERENCES
+sexp sexp_make_ephemeron_op(sexp ctx, sexp self, sexp_sint_t n, sexp key, sexp value) {
+  sexp res = sexp_alloc_type(ctx, pair, SEXP_EPHEMERON);
+  if (!sexp_exceptionp(res)) {
+    sexp_ephemeron_key(res) = key;
+    sexp_ephemeron_value(res) = value;
+  }
+  return res;
+}
+
+/* TODO: use a faster lookup */
+static sexp sexp_lookup_fileno(sexp ctx, int fd) {
+  sexp *data, x, vec = sexp_global(ctx, SEXP_G_FILE_DESCRIPTORS);
+  sexp_sint_t i, n = sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_NUM_FILE_DESCRIPTORS));
+  if (!sexp_vectorp(vec))
+    return SEXP_FALSE;
+  data = sexp_vector_data(vec);
+  for (i = 0; i < n; i++) {
+    if (sexp_ephemeronp(data[i])) {
+      x = sexp_ephemeron_key(data[i]);
+      if (sexp_filenop(x) && sexp_fileno_fd(x) == fd)
+        return x;
+    }
+  }
+  return SEXP_FALSE;
+}
+
+static void sexp_insert_fileno(sexp ctx, sexp fileno) {
+  sexp *data, *data2, tmp, vec = sexp_global(ctx, SEXP_G_FILE_DESCRIPTORS);
+  sexp_sint_t i, n2, n = sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_NUM_FILE_DESCRIPTORS));
+  if (!sexp_vectorp(vec)) {
+    vec = sexp_global(ctx, SEXP_G_FILE_DESCRIPTORS)
+        = sexp_make_vector(ctx, sexp_make_fixnum(128), SEXP_VOID);
+  } else if (n >= sexp_vector_length(vec)) {
+    data = sexp_vector_data(vec);
+    for (i = n2 = 0; i < sexp_vector_length(vec); i++)
+      if (sexp_ephemeronp(data[i]) && !sexp_brokenp(data[i]))
+        n2++;
+    if (n2 * 2 >= n)
+      n2 = n * 2;
+    tmp = sexp_global(ctx, SEXP_G_FILE_DESCRIPTORS)
+        = sexp_make_vector(ctx, sexp_make_fixnum(n2), SEXP_VOID);
+    data2 = sexp_vector_data(tmp);
+    for (i = n = 0; i < sexp_vector_length(vec); i++)
+      if (sexp_ephemeronp(data[i]) && !sexp_brokenp(data[i]))
+        data2[n++] = data[i];
+    vec = tmp;
+  }
+  sexp_vector_data(vec)[n] = sexp_make_ephemeron(ctx, fileno, SEXP_FALSE);
+  sexp_global(ctx, SEXP_G_NUM_FILE_DESCRIPTORS) = sexp_make_fixnum(n + 1);
+}
+#endif
+
 sexp sexp_make_fileno_op (sexp ctx, sexp self, sexp_sint_t n, sexp fd, sexp no_closep) {
-  sexp res;
+  sexp_gc_var1(res);
   sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, fd);
   if (sexp_unbox_fixnum(fd) < 0) return SEXP_FALSE;
+#if SEXP_USE_WEAK_REFERENCES
+  res = sexp_lookup_fileno(ctx, sexp_unbox_fixnum(fd));
+  if (sexp_filenop(res)) {
+    sexp_fileno_no_closep(res) = sexp_truep(no_closep);
+    return res;
+  }
+#endif
+  sexp_gc_preserve1(ctx, res);
   res = sexp_alloc_type(ctx, fileno, SEXP_FILENO);
   if (!sexp_exceptionp(res)) {
     sexp_fileno_fd(res) = sexp_unbox_fixnum(fd);
     sexp_fileno_openp(res) = 1;
     sexp_fileno_no_closep(res) = sexp_truep(no_closep);
+#if SEXP_USE_WEAK_REFERENCES
+    sexp_insert_fileno(ctx, res);
+#endif
   }
+  sexp_gc_release1(ctx);
   return res;
 }
 

tests/weak-tests.scm

@@ -3,21 +3,22 @@
 
 (test-begin "weak pointers")
 
-(test "preserved key and value" '("key" "value" #f)
+(test "preserved key and value" '("key1" "value1" #f)
-  (let ((key (string-append "key"))
+  (let ((key (string-append "key" "1"))
-        (value (string-append "value")))
+        (value (string-append "value" "1")))
     (let ((eph (make-ephemeron key value)))
       (gc)
       (list key (ephemeron-value eph) (ephemeron-broken? eph)))))
 
 (test "unpreserved key and value" '(#f #f #t)
-  (let ((eph (make-ephemeron (string-append "key") (string-append "value"))))
+  (let ((eph (make-ephemeron (string-append "key" "2")
+                             (string-append "value" "2"))))
     (gc)
     (list (ephemeron-key eph) (ephemeron-value eph) (ephemeron-broken? eph))))
 
-(test "unpreserved key and preserved value" '(#f "value" #t)
+(test "unpreserved key and preserved value" '(#f "value3" #t)
-  (let ((value (string-append "value")))
+  (let ((value (string-append "value" "3")))
-    (let ((eph (make-ephemeron (string-append "key") value)))
+    (let ((eph (make-ephemeron (string-append "key" "3") value)))
       (gc)
       (list (ephemeron-key eph) value (ephemeron-broken? eph)))))