Allow precise tracing of dynstacks

Gosh this was a slog

* libguile/dynstack.c (dynstack_ensure_space): Use malloc and free.
Threads have off-heap dynstacks, with manual marking.
(scm_trace_dynstack): Implement tracing.
(trace_pinned_trampoline, scm_trace_dynstack_roots): Implement tracing
for active threads.
(scm_dynstack_capture): Tag dynstacks.
* libguile/dynstack.h (scm_t_dynstack): Add a tag.
(scm_t_dynstack_winder_flags): Add SCM_F_DYNSTACK_WINDER_MANAGED.
* libguile/dynwind.h (scm_t_wind_flags): Add SCM_F_WIND_MANAGED.
* libguile/dynwind.c (scm_dynwind_unwind_handler_with_scm)
(scm_dynwind_rewind_handler_with_scm): These values need to be traced by
GC.
* libguile/scm.h (scm_tc16_dynstack_slice): New typecode.  No need for
equality etc because it shouldn't escape to Scheme (currently).
* libguile/trace.h: Add trace decls.
* libguile/threads.c (scm_trace_thread_roots): Trace dynstacks
explicitly here, as they are off-heap.

libguile/dynstack.c

@@ -1,4 +1,4 @@
-/* Copyright 2012-2013,2018
+/* Copyright 2012-2013,2018,2025
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -37,6 +37,7 @@
 #include "fluids.h"
 #include "variable.h"
 #include "threads.h"
+#include "trace.h"
 
 #include "dynstack.h"
 
@@ -44,7 +45,8 @@
 
 
 #define PROMPT_WORDS 6
-#define PROMPT_KEY(top) (SCM_PACK ((top)[0]))
+#define PROMPT_KEY_LOC(top) ((SCM*)(top))
+#define PROMPT_KEY(top) (*PROMPT_KEY_LOC(top))
 #define PROMPT_FP(top) ((ptrdiff_t) ((top)[1]))
 #define SET_PROMPT_FP(top, fp) do { top[1] = (scm_t_bits)(fp); } while (0)
 #define PROMPT_SP(top) ((ptrdiff_t) ((top)[2]))
@@ -55,18 +57,24 @@
 
 #define WINDER_WORDS 2
 #define WINDER_PROC(top) ((scm_t_guard) ((top)[0]))
-#define WINDER_DATA(top) ((void *) ((top)[1]))
+#define WINDER_DATA_LOC(top) ((void **) ((top) + 1))
+#define WINDER_DATA(top) (*WINDER_DATA_LOC(top))
 
 #define DYNWIND_WORDS 2
-#define DYNWIND_ENTER(top) (SCM_PACK ((top)[0]))
+#define DYNWIND_ENTER_LOC(top) ((SCM*)(top))
-#define DYNWIND_LEAVE(top) (SCM_PACK ((top)[1]))
+#define DYNWIND_LEAVE_LOC(top) ((SCM*)(top) + 1)
+#define DYNWIND_ENTER(top) (*DYNWIND_ENTER_LOC(top))
+#define DYNWIND_LEAVE(top) (*DYNWIND_LEAVE_LOC(top))
 
 #define WITH_FLUID_WORDS 2
-#define WITH_FLUID_FLUID(top) (SCM_PACK ((top)[0]))
+#define WITH_FLUID_FLUID_LOC(top) ((SCM*)(top))
-#define WITH_FLUID_VALUE_BOX(top) (SCM_PACK ((top)[1]))
+#define WITH_FLUID_VALUE_BOX_LOC(top) ((SCM*)(top) + 1)
+#define WITH_FLUID_FLUID(top) (*WITH_FLUID_FLUID_LOC(top))
+#define WITH_FLUID_VALUE_BOX(top) (*WITH_FLUID_VALUE_BOX_LOC(top))
 
 #define DYNAMIC_STATE_WORDS 1
-#define DYNAMIC_STATE_STATE_BOX(top) (SCM_PACK ((top)[0]))
+#define DYNAMIC_STATE_STATE_BOX_LOC(top) ((SCM*)(top))
+#define DYNAMIC_STATE_STATE_BOX(top) (*DYNAMIC_STATE_STATE_BOX_LOC(top))
 
 
 
@@ -100,22 +108,111 @@ dynstack_ensure_space (scm_t_dynstack *dynstack, size_t n)
 
   if (capacity < height + n)
     {
-      scm_t_bits *new_base;
+      scm_t_bits *old_base = dynstack->base;
-
       while (capacity < height + n)
         capacity = (capacity < 4) ? 8 : (capacity * 2);
 
-      new_base = scm_gc_malloc (capacity * sizeof(scm_t_bits), "dynstack");
+      dynstack->base = scm_malloc (capacity * sizeof(scm_t_bits));
+      dynstack->top = dynstack->base + height;
+      dynstack->limit = dynstack->base + capacity;
 
-      copy_scm_t_bits (new_base, dynstack->base, height);
+      copy_scm_t_bits (dynstack->base, old_base, height);
-      clear_scm_t_bits (dynstack->base, height);
+      clear_scm_t_bits (dynstack->base + height, capacity - height);
-        
+      free (old_base);
-      dynstack->base = new_base;
-      dynstack->top = new_base + height;
-      dynstack->limit = new_base + capacity;
     }
 }
 
+void
+scm_dynstack_init_for_thread (scm_t_dynstack *dynstack)
+{
+  dynstack->tag = -1;
+  dynstack->base = NULL;
+  dynstack->limit = NULL;
+  dynstack->top = NULL;
+  dynstack_ensure_space (dynstack, 1000);
+  dynstack->top += SCM_DYNSTACK_HEADER_LEN;
+}
+
+void
+scm_trace_dynstack (struct scm_dynstack *dynstack,
+                    void (*trace) (struct gc_edge edge,
+                                   struct gc_heap *heap,
+                                   void *trace_data),
+                    struct gc_heap *heap, void *trace_data)
+{
+  scm_t_bits *walk;
+
+  for (walk = SCM_DYNSTACK_PREV (dynstack->top); walk;
+       walk = SCM_DYNSTACK_PREV (walk))
+    {
+      scm_t_bits tag = SCM_DYNSTACK_TAG (walk);
+
+      switch (SCM_DYNSTACK_TAG_TYPE (tag))
+        {
+        case SCM_DYNSTACK_TYPE_FRAME:
+          break;
+        case SCM_DYNSTACK_TYPE_UNWINDER:
+        case SCM_DYNSTACK_TYPE_REWINDER:
+          if (SCM_DYNSTACK_TAG_FLAGS (tag) & SCM_F_DYNSTACK_WINDER_MANAGED)
+            trace (gc_edge (WINDER_DATA_LOC (walk)), heap, trace_data);
+          break;
+        case SCM_DYNSTACK_TYPE_WITH_FLUID:
+          trace (gc_edge (WITH_FLUID_FLUID_LOC (walk)), heap, trace_data);
+          trace (gc_edge (WITH_FLUID_VALUE_BOX_LOC (walk)), heap, trace_data);
+          break;
+        case SCM_DYNSTACK_TYPE_PROMPT:
+          trace (gc_edge (PROMPT_KEY_LOC (walk)), heap, trace_data);
+          // No need to trace the jmpbuf; either:
+          //   1. the prompt is active and thus the jmpbuf is on the
+          //      stack and traced conservatively already
+          //   2. the dynstack is part of a delimited continuation, in
+          //      which case the jmpbuf is garbage and will be rewound
+          //      if the dynstack is reinstated
+          //   2. the dynstack is part of an undelimited continuation, in
+          //      which case the jmpbuf is conservatively marked as part
+          //      of the associated continuation
+          break;
+        case SCM_DYNSTACK_TYPE_DYNWIND:
+          trace (gc_edge (DYNWIND_ENTER_LOC (walk)), heap, trace_data);
+          trace (gc_edge (DYNWIND_LEAVE_LOC (walk)), heap, trace_data);
+          break;
+        case SCM_DYNSTACK_TYPE_DYNAMIC_STATE:
+          trace (gc_edge (DYNAMIC_STATE_STATE_BOX_LOC (walk)), heap, trace_data);
+          break;
+        default:
+          abort ();
+        }
+    }
+}
+
+struct trace_pinned_trampoline
+{
+  void (*trace_pinned) (struct gc_ref ref,
+                        struct gc_heap *heap,
+                        void *trace_data);
+  void *trace_data;
+};
+
+static void
+trace_pinned_trampoline (struct gc_edge edge,
+                         struct gc_heap *heap,
+                         void *trace_data)
+{
+  struct trace_pinned_trampoline *data = trace_data;
+  return data->trace_pinned (gc_edge_ref (edge), heap, data->trace_data);
+}
+
+void
+scm_trace_dynstack_roots (struct scm_dynstack *dynstack,
+                          void (*trace_pinned) (struct gc_ref ref,
+                                                struct gc_heap *heap,
+                                                void *trace_data),
+                          struct gc_heap *heap, void *trace_data)
+{
+  struct trace_pinned_trampoline data = { trace_pinned, trace_data };
+  return scm_trace_dynstack (dynstack, trace_pinned_trampoline, heap, &data);
+}
+
 static inline scm_t_bits *
 push_dynstack_entry_unchecked (scm_t_dynstack *dynstack,
                                scm_t_dynstack_item_type type,
@@ -280,7 +377,6 @@ scm_dynstack_capture_all (scm_t_dynstack *dynstack)
 scm_t_dynstack *
 scm_dynstack_capture (scm_t_dynstack *dynstack, scm_t_bits *item)
 {
-  char *mem;
   scm_t_dynstack *ret;
   size_t len;
 
@@ -288,9 +384,9 @@ scm_dynstack_capture (scm_t_dynstack *dynstack, scm_t_bits *item)
   assert (item <= dynstack->top);
 
   len = dynstack->top - item + SCM_DYNSTACK_HEADER_LEN;
-  mem = scm_gc_malloc (sizeof (*ret) + len * sizeof(scm_t_bits), "dynstack");
+  ret = scm_gc_malloc (sizeof (*ret) + len * sizeof(scm_t_bits), "dynstack");
-  ret = (scm_t_dynstack *) mem;
+  ret->tag = scm_tc16_dynstack_slice;
-  ret->base = (scm_t_bits *) (mem + sizeof (*ret));
+  ret->base = ret->inline_storage;
   ret->limit = ret->base + len;
   ret->top = ret->base + len;
 

libguile/dynstack.h

@@ -1,7 +1,7 @@
 #ifndef SCM_DYNSTACK_H
 #define SCM_DYNSTACK_H
 
-/* Copyright 2012-2013,2018
+/* Copyright 2012-2013,2018,2025
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -36,9 +36,11 @@
 
 typedef struct scm_dynstack
 {
+  scm_t_bits tag;
   scm_t_bits *base;
   scm_t_bits *top;
   scm_t_bits *limit;
+  scm_t_bits inline_storage[];
 } scm_t_dynstack;
 
 
@@ -133,7 +135,8 @@ typedef enum {
 } scm_t_dynstack_frame_flags;
 
 typedef enum {
-  SCM_F_DYNSTACK_WINDER_EXPLICIT = (1 << SCM_DYNSTACK_TAG_FLAGS_SHIFT)
+  SCM_F_DYNSTACK_WINDER_EXPLICIT = (1 << SCM_DYNSTACK_TAG_FLAGS_SHIFT),
+  SCM_F_DYNSTACK_WINDER_MANAGED = (2 << SCM_DYNSTACK_TAG_FLAGS_SHIFT)
 } scm_t_dynstack_winder_flags;
 
 typedef enum {
@@ -145,6 +148,8 @@ typedef void (*scm_t_guard) (void *);
 
 
 
+SCM_INTERNAL void scm_dynstack_init_for_thread (scm_t_dynstack *);
+
 /* Pushing and popping entries on the dynamic stack.  */
 
 SCM_INTERNAL void scm_dynstack_push_frame (scm_t_dynstack *,

libguile/dynwind.c

@@ -1,4 +1,4 @@
-/* Copyright 1995-1996,1998-2001,2003-2004,2006,2008,2010-2012,2018
+/* Copyright 1995-1996,1998-2001,2003-2004,2006,2008,2010-2012,2018,2025
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -99,7 +99,8 @@ scm_dynwind_unwind_handler_with_scm (void (*proc) (SCM), SCM data,
 				     scm_t_wind_flags flags)
 {
   /* FIXME: This is not a safe cast.  */
-  scm_dynwind_unwind_handler ((scm_t_guard) proc, SCM2PTR (data), flags);
+  scm_dynwind_unwind_handler ((scm_t_guard) proc, SCM2PTR (data),
+                              flags | SCM_F_WIND_MANAGED);
 }
 
 void
@@ -107,7 +108,8 @@ scm_dynwind_rewind_handler_with_scm (void (*proc) (SCM), SCM data,
 				     scm_t_wind_flags flags)
 {
   /* FIXME: This is not a safe cast.  */
-  scm_dynwind_rewind_handler ((scm_t_guard) proc, SCM2PTR (data), flags);
+  scm_dynwind_rewind_handler ((scm_t_guard) proc, SCM2PTR (data),
+                              flags | SCM_F_WIND_MANAGED);
 }
 
 void

libguile/dynwind.h

@@ -1,7 +1,7 @@
 #ifndef SCM_DYNWIND_H
 #define SCM_DYNWIND_H
 
-/* Copyright 1995-1996,1998-2000,2003-2004,2006,2008,2011-2012,2018
+/* Copyright 1995-1996,1998-2000,2003-2004,2006,2008,2011-2012,2018,2025
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -37,7 +37,8 @@ typedef enum {
 } scm_t_dynwind_flags;
 
 typedef enum {
-  SCM_F_WIND_EXPLICITLY = SCM_F_DYNSTACK_WINDER_EXPLICIT
+  SCM_F_WIND_EXPLICITLY = SCM_F_DYNSTACK_WINDER_EXPLICIT,
+  SCM_F_WIND_MANAGED = SCM_F_DYNSTACK_WINDER_MANAGED
 } scm_t_wind_flags;
 
 SCM_API void scm_dynwind_begin (scm_t_dynwind_flags);

libguile/scm.h

@@ -517,6 +517,7 @@ typedef uintptr_t scm_t_bits;
 #define scm_tc16_random_state		0x067f
 #define scm_tc16_regexp			0x077f
 #define scm_tc16_locale			0x087f
+#define scm_tc16_dynstack_slice		0x097f
 
 
 /* Definitions for tc16: */

libguile/threads.c

@@ -87,18 +87,6 @@
 /* FIXME: For the moment, the bodies of thread objects are traced
    conservatively; only bdw, heap-conservative-mmc, and
    heap-conservative-parallel-mmc are supported.  */
-static void
-scm_trace_dynstack (scm_t_dynstack *dynstack,
-                    void (*trace_edge) (struct gc_edge edge,
-                                        struct gc_heap *heap,
-                                        void *trace_data),
-                    struct gc_heap *heap, void *trace_data)
-{
-  /* FIXME: Untagged array.  Perhaps this should be off-heap... or
-     interleaved on the main stack.  */
-  trace_edge (gc_edge (&dynstack->base), heap, trace_data);
-}
-
 void
 scm_trace_thread (struct scm_thread *thread,
                   void (*trace_edge) (struct gc_edge edge,
@@ -151,6 +139,10 @@ scm_trace_thread_roots (struct scm_thread *thread,
                         struct gc_heap *heap, void *trace_data)
 {
   trace_pinned (gc_ref_from_heap_object (thread), heap, trace_data);
+#if GC_CONSERVATIVE_TRACE
+  scm_trace_dynstack_roots (&thread->dynstack, trace_pinned, heap, trace_data);
+#endif
+  /* FIXME: Trace  is not a tagged allocation.  */
   scm_trace_vm_roots (&thread->vm, trace_pinned, trace_ambiguous, heap,
                       trace_data);
 }
@@ -480,9 +472,7 @@ guilify_self_2 (SCM dynamic_state)
   t->dynamic_state->thread_local_values = scm_c_make_hash_table (0);
   scm_set_current_dynamic_state (dynamic_state);
 
-  t->dynstack.base = scm_gc_malloc (16 * sizeof (scm_t_bits), "dynstack");
+  scm_dynstack_init_for_thread (&t->dynstack);
-  t->dynstack.limit = t->dynstack.base + 16;
-  t->dynstack.top = t->dynstack.base + SCM_DYNSTACK_HEADER_LEN;
 
   t->block_asyncs = 0;
 }

libguile/trace.h

@@ -23,11 +23,13 @@
 
 #include "libguile/scm.h"
 #include "gc-ref.h"
+#include "gc-edge.h"
 
 
 
 struct scm_thread;
 struct scm_vm;
+struct scm_dynstack;
 struct gc_heap;
 struct gc_heap_roots { int unused; };
 
@@ -78,5 +80,20 @@ scm_trace_loader_roots (void (*trace_ambiguous) (uintptr_t lo,
                         struct gc_heap *heap,
                         void *trace_data);
 
+SCM_INTERNAL void
+scm_trace_dynstack (struct scm_dynstack *dynstack,
+                    void (*trace) (struct gc_edge edge,
+                                   struct gc_heap *heap,
+                                   void *trace_data),
+                    struct gc_heap *heap,
+                    void *trace_data);
+
+SCM_INTERNAL void
+scm_trace_dynstack_roots (struct scm_dynstack *dynstack,
+                          void (*trace_pinned) (struct gc_ref ref,
+                                                struct gc_heap *heap,
+                                                void *trace_data),
+                          struct gc_heap *heap,
+                          void *trace_data);
 
 #endif  /* SCM_THREADS_INTERNAL_H */