Re: Collecting markers with MPS

[Helmut Eller <eller.helmut@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 375 bytes --]

On Wed, Apr 24 2024, Gerd Möllmann wrote:

> Makes sense to me, but I must say that I have 0 experience with that
> using MPS. It might require some experimentation how to about
> implementing such weak references, but that could be fun.

I implemented such weak references in the patch below.  Do I use the
IGC_OBJ_WEAK tag roughly how you intended it?

Helmut


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Experimental-weak-ref-objects.patch --]
[-- Type: text/x-diff, Size: 9677 bytes --]

From 4b0d85a06e6cec4a8c77f271e25cd87abaa52fdc Mon Sep 17 00:00:00 2001
From: Helmut Eller <eller.helmut@gmail.com>
Date: Wed, 24 Apr 2024 20:54:16 +0200
Subject: [PATCH] Experimental weak-ref objects

---
 src/data.c            |   5 +-
 src/igc.c             | 158 ++++++++++++++++++++++++++++++++++++++++--
 src/igc.h             |  16 +++++
 src/lisp.h            |   1 +
 src/pdumper.c         |   2 +
 src/print.c           |  10 +++
 test/src/igc-tests.el |  16 +++++
 7 files changed, 200 insertions(+), 8 deletions(-)
 create mode 100644 test/src/igc-tests.el

diff --git a/src/data.c b/src/data.c
index d52b73b8681..49b33727d75 100644
--- a/src/data.c
+++ b/src/data.c
@@ -296,7 +296,10 @@ DEFUN ("cl-type-of", Fcl_type_of, Scl_type_of, 1, 1, 0,
           return Qsqlite;
         case PVEC_SUB_CHAR_TABLE:
           return Qsub_char_table;
-        /* "Impossible" cases.  */
+	case PVEC_WEAK_REF:
+	  return Qweak_ref;
+
+	/* "Impossible" cases.  */
 	case PVEC_MISC_PTR:
         case PVEC_OTHER:
         case PVEC_FREE: ;
diff --git a/src/igc.c b/src/igc.c
index d0b3e8e3fa6..e64e0621c77 100644
--- a/src/igc.c
+++ b/src/igc.c
@@ -63,6 +63,12 @@
 # warning "HAVE_TEXT_CONVERSION not supported"
 #endif
 
+struct Lisp_Weak_Ref
+{
+  union vectorlike_header header;
+  Lisp_Object ref;
+} GCALIGNED_STRUCT;
+
 /* Note: Emacs will call allocation functions whlle aborting. This leads
    to all sorts of interesting phenomena when an assertion fails inside
    a function called from MPS.
@@ -1024,9 +1030,92 @@ fix_face_cache (mps_ss_t ss, struct face_cache *c)
 }
 
 static mps_res_t
-fix_weak (mps_ss_t ss, mps_addr_t base)
+fix_weak_ref (mps_ss_t ss, struct Lisp_Weak_Ref *wref)
+{
+  MPS_SCAN_BEGIN (ss)
+  {
+    const mps_word_t tagged_word = *(mps_word_t *)&wref->ref;
+    const enum Lisp_Type tag = tagged_word & IGC_TAG_MASK;
+
+    switch (tag)
+      {
+      case Lisp_Int0:
+      case Lisp_Int1:
+	return MPS_RES_OK;
+
+      case Lisp_Type_Unused0:
+	emacs_abort ();
+
+      case Lisp_Symbol:
+	{
+	  ptrdiff_t off = tagged_word ^ Lisp_Symbol;
+	  mps_addr_t client = (mps_addr_t)((char *)lispsym + off);
+	  if (is_mps (client))
+	    {
+	      mps_addr_t base = client_to_base (client);
+	      if (MPS_FIX1 (ss, base))
+		{
+		  mps_res_t res = MPS_FIX2 (ss, &base);
+		  if (res != MPS_RES_OK)
+		    return res;
+		  if (base == NULL)
+		    {
+		      wref->ref = Qnil;
+		    }
+		  else
+		    {
+		      client = base_to_client (base);
+		      ptrdiff_t new_off = (char *)client - (char *)lispsym;
+		      wref->ref = (Lisp_Object)(new_off | tag);
+		    }
+		}
+	    }
+	}
+	break;
+
+      default:
+	{
+	  const mps_addr_t client = (mps_addr_t)(tagged_word ^ tag);
+	  if (is_mps (client))
+	    {
+	      mps_addr_t base = client_to_base (client);
+	      if (MPS_FIX1 (ss, base))
+		{
+		  const mps_res_t res = MPS_FIX2 (ss, &base);
+		  if (res != MPS_RES_OK)
+		    return res;
+		  if (base == NULL)
+		    {
+		      wref->ref = Qnil;
+		    }
+		  else
+		    {
+		      const mps_addr_t client2 = base_to_client (base);
+		      wref->ref = (Lisp_Object)((mps_word_t)client2 | tag);
+		    }
+		}
+	    }
+	}
+      }
+  }
+  MPS_SCAN_END (ss);
+  return MPS_RES_OK;
+}
+
+static mps_res_t
+fix_weak (mps_ss_t ss, struct igc_header* base)
 {
-  MPS_SCAN_BEGIN (ss) { igc_assert (!"fix_weak"); }
+  MPS_SCAN_BEGIN (ss) {
+    const mps_addr_t client = base_to_client(base);
+    switch (base->pvec_type)
+      {
+      case PVEC_WEAK_REF:
+	IGC_FIX_CALL_FN (ss, struct Lisp_Weak_Ref, client, fix_weak_ref);
+	break;
+      default:
+	igc_assert (!"fix_weak");
+      }
+  }
   MPS_SCAN_END (ss);
   return MPS_RES_OK;
 }
@@ -1139,7 +1228,7 @@ dflt_scanx (mps_ss_t ss, mps_addr_t base_start, mps_addr_t base_limit,
 	    break;
 
 	  case IGC_OBJ_WEAK:
-	    IGC_FIX_CALL_FN (ss, mps_word_t, client, fix_weak);
+	    IGC_FIX_CALL_FN (ss, struct igc_header, base, fix_weak);
 	    break;
 	  }
       }
@@ -1633,6 +1722,9 @@ fix_vector (mps_ss_t ss, struct Lisp_Vector *v)
 #endif
 	IGC_FIX_CALL_FN (ss, struct Lisp_Vector, v, fix_vectorlike);
 	break;
+
+      case PVEC_WEAK_REF:
+	emacs_abort ();
       }
   }
   MPS_SCAN_END (ss);
@@ -2231,6 +2323,7 @@ finalize_vector (mps_addr_t v)
     case PVEC_XWIDGET_VIEW:
     case PVEC_TERMINAL:
     case PVEC_MARKER:
+    case PVEC_WEAK_REF:
       igc_assert (!"not implemented");
       break;
     }
@@ -2321,6 +2414,7 @@ maybe_finalize (mps_addr_t client, enum pvec_type tag)
 #ifdef IN_MY_FORK
     case PVEC_PACKAGE:
 #endif
+    case PVEC_WEAK_REF:
       break;
     }
 }
@@ -2387,9 +2481,11 @@ thread_ap (enum igc_obj_type type)
     case IGC_OBJ_PAD:
     case IGC_OBJ_FWD:
     case IGC_OBJ_LAST:
-    case IGC_OBJ_WEAK:
       emacs_abort ();
 
+    case IGC_OBJ_WEAK:
+      return t->d.weak_weak_ap;
+
     case IGC_OBJ_CONS:
     case IGC_OBJ_SYMBOL:
     case IGC_OBJ_INTERVAL:
@@ -2425,6 +2521,14 @@ igc_collect (void)
   mps_arena_release (gc->arena);
 }
 
+DEFUN ("igc--collect", Figc__collect, Sigc__collect, 0, 0, 0, doc
+       : /* */)
+(void)
+{
+  igc_collect ();
+  return Qnil;
+}
+
 static unsigned
 obj_hash (void)
 {
@@ -2665,11 +2769,46 @@ igc_make_face_cache (void)
   return c;
 }
 
-struct Lisp_Buffer_Local_Value *
-igc_alloc_blv (void)
+DEFUN ("igc-make-weak-ref", Figc_make_weak_ref, Sigc_make_weak_ref, 1, 1, 0,
+       doc
+       : /* todo */)
+(Lisp_Object target)
+{
+  const enum pvec_type type = PVEC_WEAK_REF;
+  struct Lisp_Weak_Ref *wref = alloc (sizeof *wref, IGC_OBJ_WEAK, type);
+  int nwords_lisp = VECSIZE(struct Lisp_Weak_Ref);
+  XSETPVECTYPESIZE (wref, type, nwords_lisp, 0);
+  maybe_finalize (wref, type);
+  wref->ref = target;
+  Lisp_Object obj = make_lisp_ptr (wref, Lisp_Vectorlike);
+  return obj;
+}
+
+static void
+CHECK_WEAK_REF_P (Lisp_Object x)
+{
+  CHECK_TYPE (WEAK_REF_P (x), Qweak_ref_p, x);
+}
+
+Lisp_Object
+igc_weak_ref_deref (struct Lisp_Weak_Ref *wref)
+{
+  return wref->ref;
+}
+
+DEFUN ("igc-weak-ref-deref", Figc_weak_reaf_deref, Sigc_weak_ref_deref, 1, 1,
+       0, doc
+       : /* todo */)
+(Lisp_Object obj)
+{
+  CHECK_WEAK_REF_P (obj);
+  return igc_weak_ref_deref (XWEAK_REF (obj));
+}
+
+struct Lisp_Buffer_Local_Value *igc_alloc_blv (void)
 {
   struct Lisp_Buffer_Local_Value *blv
-    = alloc (sizeof *blv, IGC_OBJ_BLV, PVEC_FREE);
+      = alloc (sizeof *blv, IGC_OBJ_BLV, PVEC_FREE);
   return blv;
 }
 
@@ -2871,7 +3010,12 @@ syms_of_igc (void)
 {
   defsubr (&Sigc_info);
   defsubr (&Sigc_roots);
+  defsubr (&Sigc_make_weak_ref);
+  defsubr (&Sigc_weak_ref_deref);
+  defsubr (&Sigc__collect);
   DEFSYM (Qambig, "ambig");
   DEFSYM (Qexact, "exact");
+  DEFSYM (Qweak_ref_p, "weak-ref-p");
+  DEFSYM (Qweak_ref, "weak-ref");
   Fprovide (intern_c_string ("mps"), Qnil);
 }
diff --git a/src/igc.h b/src/igc.h
index 0183b8da71f..e29e8f7cecc 100644
--- a/src/igc.h
+++ b/src/igc.h
@@ -93,6 +93,22 @@ #define EMACS_IGC_H
 void igc_root_create_exact (Lisp_Object *start, Lisp_Object *end);
 void igc_root_create_exact_ptr (void *var_addr);
 
+struct Lisp_Weak_Ref;
+Lisp_Object igc_weak_ref_deref (struct Lisp_Weak_Ref *);
+
+INLINE bool
+WEAK_REF_P (Lisp_Object x)
+{
+  return PSEUDOVECTORP (x, PVEC_WEAK_REF);
+}
+
+INLINE struct Lisp_Weak_Ref *
+XWEAK_REF (Lisp_Object a)
+{
+  eassert (WEAK_REF_P (a));
+  return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Weak_Ref);
+}
+
 # define eassert_not_mps() eassert (false)
 #else
 # define igc_break() (void) 0
diff --git a/src/lisp.h b/src/lisp.h
index ce1516e9673..32b28921c44 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -1047,6 +1047,7 @@ DEFINE_GDB_SYMBOL_END (PSEUDOVECTOR_FLAG)
   PVEC_TS_NODE,
   PVEC_TS_COMPILED_QUERY,
   PVEC_SQLITE,
+  PVEC_WEAK_REF,
 
   /* These should be last, for internal_equal and sxhash_obj.  */
   PVEC_COMPILED,
diff --git a/src/pdumper.c b/src/pdumper.c
index 8b179247db0..cca773a41bf 100644
--- a/src/pdumper.c
+++ b/src/pdumper.c
@@ -3170,6 +3170,8 @@ dump_vectorlike (struct dump_context *ctx,
     case PVEC_TS_NODE:
     case PVEC_TS_COMPILED_QUERY:
       break;
+    case PVEC_WEAK_REF:
+      emacs_abort();
     }
   char msg[60];
   snprintf (msg, sizeof msg, "pseudovector type %d", (int) ptype);
diff --git a/src/print.c b/src/print.c
index 81b6439fd7b..a2bd8ef0b19 100644
--- a/src/print.c
+++ b/src/print.c
@@ -33,6 +33,7 @@ Copyright (C) 1985-2024 Free Software Foundation, Inc.
 #include "blockinput.h"
 #include "xwidget.h"
 #include "dynlib.h"
+#include "igc.h"
 
 #include <c-ctype.h>
 #include <float.h>
@@ -2089,6 +2090,15 @@ print_vectorlike_unreadable (Lisp_Object obj, Lisp_Object printcharfun,
 	return;
       }
 
+    case PVEC_WEAK_REF:
+      {
+	Lisp_Object target = igc_weak_ref_deref (XWEAK_REF(obj));
+	print_c_string ("#<weak-ref ", printcharfun);
+	print_object (target, printcharfun, escapeflag);
+	print_c_string (">", printcharfun);
+	return;
+      }
+
     /* Types handled earlier.  */
     case PVEC_NORMAL_VECTOR:
     case PVEC_RECORD:
diff --git a/test/src/igc-tests.el b/test/src/igc-tests.el
new file mode 100644
index 00000000000..02caf6661f5
--- /dev/null
+++ b/test/src/igc-tests.el
@@ -0,0 +1,16 @@
+;;; igc-tests.el --- Tests for igc.c                -*- lexical-binding: t -*-
+
+(require 'ert)
+
+(defvar igc-test-v0 (igc-make-weak-ref (list 1 2)))
+(defvar igc-test-v1 (igc-make-weak-ref (make-symbol "foo")))
+
+(ert-deftest igc-test-weak-refs ()
+  (igc--collect)
+  (garbage-collect)
+  (should (equal (igc-weak-ref-deref igc-test-v0) nil))
+  (should (equal (igc-weak-ref-deref igc-test-v1) nil))
+  (let ((wref (igc-make-weak-ref (list 3 4))))
+    (should (equal (igc-weak-ref-deref wref) '(3 4)))))
+
+(provide 'igc-tests)
-- 
2.39.2