Re: MPS prstack

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

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

On Wed, May 22 2024, Helmut Eller wrote:

> There is another one: ppstack.  I wasn't able to create a small test
> case for this but ppstack is needed when print-circle=t.  The native
> compiler uses that a lot.

This needs some work.  The patches below should help a bit.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-For-igc_xpalloc_exact-make-PA-an-in-out-parameter.patch --]
[-- Type: text/x-diff, Size: 3498 bytes --]

From 316e6894d6d432be763593b2e8ff816f413264dd Mon Sep 17 00:00:00 2001
From: Helmut Eller <eller.helmut@gmail.com>
Date: Fri, 24 May 2024 15:49:23 +0200
Subject: [PATCH 1/2] For igc_xpalloc_exact, make PA an in-out parameter

Because igc_xpalloc_exact uses mps_arena_release the scan_area callback
may be called before igc_xpalloc_exact returns.  With an in-out
parameter, the client has the option to receive the new address before
the igc_xpalloc_exact returns.

* src/igc.h (igc_xpalloc_exact): Change the type of PA.
* src/igc.c (igc_xpalloc_exact): Implement the new protocol.
* src/print.c (grow_pp_stack, grow_print_stack): Update accordingly.
---
 src/igc.c   | 11 ++++++-----
 src/igc.h   |  6 +++---
 src/print.c |  8 ++++----
 3 files changed, 13 insertions(+), 12 deletions(-)

diff --git a/src/igc.c b/src/igc.c
index dc4512713f7..4f22221e952 100644
--- a/src/igc.c
+++ b/src/igc.c
@@ -2416,13 +2416,14 @@ scan_xpalloced (mps_ss_t ss, void *start, void *end, void *closure)
   return scan_area ((struct igc_opaque *)ss, start, end, scan_cell);
 }
 
-void *
-igc_xpalloc_exact (void *pa, ptrdiff_t *nitems, ptrdiff_t nitems_incr_min,
-		   ptrdiff_t nitems_max, ptrdiff_t item_size,
-		   igc_scan_area_t scan_area)
+void
+igc_xpalloc_exact (void **pa_cell, ptrdiff_t *nitems,
+		   ptrdiff_t nitems_incr_min, ptrdiff_t nitems_max,
+		   ptrdiff_t item_size, igc_scan_area_t scan_area)
 {
   IGC_WITH_PARKED (global_igc)
   {
+    void *pa = *pa_cell;
     if (pa)
       {
 	struct igc_root_list *r = root_find (pa);
@@ -2433,8 +2434,8 @@ igc_xpalloc_exact (void *pa, ptrdiff_t *nitems, ptrdiff_t nitems_incr_min,
     char *end = (char *)pa + *nitems * item_size;
     root_create (global_igc, pa, end, mps_rank_exact (),
 		 scan_xpalloced, scan_area, false);
+    *pa_cell = pa;
   }
-  return pa;
 }
 
 void *
diff --git a/src/igc.h b/src/igc.h
index fb37ce22e22..5b97787916c 100644
--- a/src/igc.h
+++ b/src/igc.h
@@ -84,9 +84,9 @@ #define EMACS_IGC_H
 typedef igc_scan_result_t (*igc_scan_area_t) (struct igc_opaque *,
 					      void *start, void *end,
 					      igc_scan_cell_t fun);
-void *igc_xpalloc_exact (void *pa, ptrdiff_t *nitems,
-			 ptrdiff_t nitems_incr_min, ptrdiff_t nitems_max,
-			 ptrdiff_t item_size, igc_scan_area_t scan);
+void igc_xpalloc_exact (void **pa_cell, ptrdiff_t *nitems,
+			ptrdiff_t nitems_incr_min, ptrdiff_t nitems_max,
+			ptrdiff_t item_size, igc_scan_area_t scan);
 
 void *igc_xnrealloc_ambig (void *pa, ptrdiff_t nitems, ptrdiff_t item_size);
 
diff --git a/src/print.c b/src/print.c
index c87597be899..5aec73c15e3 100644
--- a/src/print.c
+++ b/src/print.c
@@ -1359,8 +1359,8 @@ grow_pp_stack (void)
   struct print_pp_stack *ps = &ppstack;
   eassert (ps->sp == ps->size);
 #ifdef HAVE_MPS
-  ps->stack = igc_xpalloc_exact (ps->stack, &ps->size, 1, -1,
-				 sizeof *ps->stack, scan_ppstack);
+  igc_xpalloc_exact ((void **)&ppstack.stack, &ps->size, 1, -1,
+		     sizeof *ps->stack, scan_ppstack);
 #else
   ps->stack = xpalloc (ps->stack, &ps->size, 1, -1, sizeof *ps->stack);
 #endif
@@ -2273,8 +2273,8 @@ grow_print_stack (void)
   struct print_stack *ps = &prstack;
   eassert (ps->sp == ps->size);
 #ifdef HAVE_MPS
-  ps->stack = igc_xpalloc_exact (ps->stack, &ps->size, 1, -1,
-				 sizeof *ps->stack, scan_prstack);
+  igc_xpalloc_exact ((void **)&prstack.stack, &ps->size, 1, -1,
+		     sizeof *ps->stack, scan_prstack);
 #else
   ps->stack = xpalloc (ps->stack, &ps->size, 1, -1, sizeof *ps->stack);
 #endif
-- 
2.39.2


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0002-Safer-use-of-ppstack.patch --]
[-- Type: text/x-diff, Size: 3113 bytes --]

From dd2033d482a29dff2275daf082148ffc2bea16fd Mon Sep 17 00:00:00 2001
From: Helmut Eller <eller.helmut@gmail.com>
Date: Fri, 24 May 2024 16:00:12 +0200
Subject: [PATCH 2/2] Safer use of ppstack

In print_pp_entry, the u.values fields holds a pointer into the interior
of a vectorlike object.  This doesn't work for a moving GC.  It's safer
to keep the original object and access it with AREF.

* print.c (print_pp_entry): Add a vectorlike variant to the union.
(scan_ppstack, pp_stack_push_values, print_preprocess): Update accordingly.
---
 src/print.c | 34 ++++++++++++++++++++++++++++++----
 1 file changed, 30 insertions(+), 4 deletions(-)

diff --git a/src/print.c b/src/print.c
index 5aec73c15e3..cc86e1e9710 100644
--- a/src/print.c
+++ b/src/print.c
@@ -1314,7 +1314,11 @@ #define PRINT_CIRCLE_CANDIDATE_P(obj)			   \
   ptrdiff_t n;			/* number of values, or 0 if a single value */
   union {
     Lisp_Object value;		/* when n = 0 */
+#ifdef HAVE_MPS
+    Lisp_Object vectorlike;	/* when n > 0 */
+#else
     Lisp_Object *values;	/* when n > 0 */
+#endif
   } u;
 };
 
@@ -1345,9 +1349,8 @@ scan_ppstack (struct igc_opaque *op, void *start, void *end,
       else
 	{
 	  eassert (p->n > 0);
-	  for (size_t i = 0; i < p->n; i++)
-	    if (err = scan1 (op, &p->u.values[i]), err != 0)
-	      return err;
+	  if (err = scan1 (op, &p->u.vectorlike), err != 0)
+	    return err;
 	}
     }
   return 0;
@@ -1376,6 +1379,20 @@ pp_stack_push_value (Lisp_Object value)
 							.u.value = value};
 }
 
+#ifdef HAVE_MPS
+static inline void
+pp_stack_push_values (Lisp_Object vectorlike, ptrdiff_t n)
+{
+  eassert (VECTORLIKEP (vectorlike));
+  eassume (n >= 0);
+  if (n == 0)
+    return;
+  if (ppstack.sp >= ppstack.size)
+    grow_pp_stack ();
+  ppstack.stack[ppstack.sp++]
+      = (struct print_pp_entry){ .n = n, .u.vectorlike = vectorlike };
+}
+#else
 static inline void
 pp_stack_push_values (Lisp_Object *values, ptrdiff_t n)
 {
@@ -1387,6 +1404,7 @@ pp_stack_push_values (Lisp_Object *values, ptrdiff_t n)
   ppstack.stack[ppstack.sp++] = (struct print_pp_entry){.n = n,
 							.u.values = values};
 }
+#endif
 
 static inline bool
 pp_stack_empty_p (void)
@@ -1409,7 +1427,11 @@ pp_stack_pop (void)
   e->n--;
   if (e->n == 0)
     --ppstack.sp;		/* last value consumed */
+#ifdef HAVE_MPS
+  return AREF (e->u.vectorlike, e->n);
+#else
   return (++e->u.values)[-1];
+#endif
 }
 
 /* Construct Vprint_number_table for the print-circle feature
@@ -1475,13 +1497,17 @@ print_preprocess (Lisp_Object obj)
 
 		case Lisp_Vectorlike:
 		  {
-		    struct Lisp_Vector *vec = XVECTOR (obj);
 		    ptrdiff_t size = ASIZE (obj);
 		    if (size & PSEUDOVECTOR_FLAG)
 		      size &= PSEUDOVECTOR_SIZE_MASK;
 		    ptrdiff_t start = (SUB_CHAR_TABLE_P (obj)
 				       ? SUB_CHAR_TABLE_OFFSET : 0);
+#ifdef HAVE_MPS
+		    pp_stack_push_values (obj, size - start);
+#else
+		    struct Lisp_Vector *vec = XVECTOR (obj);
 		    pp_stack_push_values (vec->contents + start, size - start);
+#endif
 		    if (HASH_TABLE_P (obj))
 		      {
 			struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
-- 
2.39.2