From 4b0d85a06e6cec4a8c77f271e25cd87abaa52fdc Mon Sep 17 00:00:00 2001 From: Helmut Eller 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 #include @@ -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 ("#", 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