Arrange to pin objects captured by a delimited continuation

* libguile/vm.h (struct scm_vm_cont): Include the tag word, and put
flags there.  Rename stack bottom to stack slice and make a flexible
array.
(scm_is_vm_cont):
(scm_to_vm_cont):
(scm_from_vm_cont):
(scm_vm_cont_is_partial):
(scm_vm_cont_is_rewindable): New build-time helpers.

* libguile/continuations.c (scm_i_make_continuation):
(scm_i_continuation_to_frame):
(copy_stack_and_call):
* libguile/continuations.h (scm_t_contregs):
* libguile/frames.c (frame_stack_top):
* libguile/stacks.c (scm_make_stack): Adapt to take struct scm_vm_cont*
instead of SCM for continuations.

* libguile/vm.c (capture_stack): Adapt to scm_vm_cont change.  Use new
gc_resolve_conservative_ref API to pin conservative refs from the
captured stack.
(scm_i_vm_cont_to_frame):
(scm_i_capture_current_stack):
(reinstate_continuation_x):
(capture_continuation):
(compose_continuation):
(capture_delimited_continuation):
(abort_to_prompt): Adapt to type changes.

libguile/continuations.c

@@ -183,7 +183,7 @@ restore_auxiliary_stack (scm_thread *thread, scm_t_contregs *continuation)
 }
 
 SCM 
-scm_i_make_continuation (scm_thread *thread, SCM vm_cont)
+scm_i_make_continuation (scm_thread *thread, struct scm_vm_cont *vm_cont)
 {
   SCM cont;
   scm_t_contregs *continuation;
@@ -221,9 +221,9 @@ scm_i_continuation_to_frame (SCM continuation, struct scm_frame *frame)
   contregs = SCM_PROGRAM_FREE_VARIABLE_REF (continuation, 0);
   cont = SCM_CONTREGS (contregs);
 
-  if (scm_is_true (cont->vm_cont))
+  if (cont->vm_cont)
     {
-      struct scm_vm_cont *data = SCM_VM_CONT_DATA (cont->vm_cont);
+      struct scm_vm_cont *data = cont->vm_cont;
 
       frame->stack_holder = data;
       frame->fp_offset = data->fp_offset;
@@ -295,7 +295,7 @@ copy_stack_and_call (scm_t_contregs *continuation,
   scm_t_bits *joint;
   scm_thread *thread = SCM_I_CURRENT_THREAD;
 
-  dynstack = SCM_VM_CONT_DATA (continuation->vm_cont)->dynstack;
+  dynstack = continuation->vm_cont->dynstack;
 
   joint = scm_dynstack_unwind_fork (&thread->dynstack, dynstack);
 

libguile/continuations.h

@@ -1,7 +1,7 @@
 #ifndef SCM_CONTINUATIONS_H
 #define SCM_CONTINUATIONS_H
 
-/* Copyright 1995-1996,2000-2001,2006,2008-2010,2012-2014,2018
+/* Copyright 1995-1996,2000-2001,2006,2008-2010,2012-2014,2018,2025
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -44,6 +44,8 @@
 	   in the num_stack_items field of the structure.
 */
 
+struct scm_vm_cont;
+
 typedef struct 
 {
   jmp_buf jmpbuf;
@@ -53,7 +55,7 @@ typedef struct
 #endif
   size_t num_stack_items;   /* size of the saved stack.  */
   SCM root;                 /* continuation root identifier.  */
-  SCM vm_cont;              /* vm's stack and regs */
+  struct scm_vm_cont *vm_cont; /* vm's stack and regs */
 
   /* The offset from the live stack location to this copy.  This is
      used to adjust pointers from within the copied stack to the stack
@@ -71,7 +73,8 @@ typedef struct
 
 
 
-SCM_INTERNAL SCM scm_i_make_continuation (scm_thread *thread, SCM vm_cont);
+SCM_INTERNAL SCM scm_i_make_continuation (scm_thread *thread,
+                                          struct scm_vm_cont *vm_cont);
 SCM_INTERNAL void scm_i_reinstate_continuation (SCM cont,
                                                 uint8_t *mra) SCM_NORETURN;
 

libguile/frames.c

@@ -1,4 +1,4 @@
-/* Copyright 2001,2009-2015,2018,2021
+/* Copyright 2001,2009-2015,2018,2021,2025
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -81,7 +81,7 @@ frame_stack_top (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
       case SCM_VM_FRAME_KIND_CONT: 
         {
           struct scm_vm_cont *cont = frame->stack_holder;
-          return cont->stack_bottom + cont->stack_size;
+          return &cont->stack_slice[cont->stack_size];
         }
 
       case SCM_VM_FRAME_KIND_VM:

libguile/stacks.c

@@ -1,4 +1,4 @@
-/* Copyright 1996-1997,2000-2001,2006-2015,2017-2019
+/* Copyright 1996-1997,2000-2001,2006-2015,2017-2019,2025
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -324,12 +324,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
      scm_make_stack was given.  */
   if (scm_is_eq (obj, SCM_BOOL_T))
     {
-      SCM cont;
+      struct scm_vm_cont *c = scm_i_capture_current_stack ();
-      struct scm_vm_cont *c;
-
-      cont = scm_i_capture_current_stack ();
-      c = SCM_VM_CONT_DATA (cont);
-
       kind = SCM_VM_FRAME_KIND_CONT;
       frame.stack_holder = c;
       frame.fp_offset = c->fp_offset;

libguile/vm.c

@@ -145,7 +145,7 @@ scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate)
 int
 scm_i_vm_cont_to_frame (SCM cont, struct scm_frame *frame)
 {
-  struct scm_vm_cont *data = SCM_VM_CONT_DATA (cont);
+  struct scm_vm_cont *data = scm_to_vm_cont (cont);
 
   frame->stack_holder = data;
   frame->fp_offset = data->fp_offset;
@@ -158,8 +158,9 @@ scm_i_vm_cont_to_frame (SCM cont, struct scm_frame *frame)
 /* Ideally we could avoid copying the C stack if the continuation root
    is inside VM code, and call/cc was invoked within that same call to
    vm_run.  That's currently not implemented.  */
-static SCM
+static struct scm_vm_cont*
-capture_stack (union scm_vm_stack_element *stack_top,
+capture_stack (scm_thread *thread,
+               union scm_vm_stack_element *stack_top,
                union scm_vm_stack_element *fp,
                union scm_vm_stack_element *sp,
                uint32_t *vra,
@@ -171,24 +172,31 @@ capture_stack (union scm_vm_stack_element *stack_top,
 
   stack_size = stack_top - sp;
 
-  /* Allocate the 'scm_vm_cont' struct and the stack at once.  That way,
+  p = scm_gc_malloc (sizeof (*p) + stack_size * sizeof (p->stack_slice[0]),
-     keeping a pointer to 'p->stack_bottom' around won't retain it.
-     See <https://bugs.gnu.org/59021>.  */
-  p = scm_gc_malloc (sizeof (*p) + stack_size * sizeof (*p->stack_bottom),
                      "capture_vm_cont");
-
+  p->tag_and_flags = scm_tc7_vm_cont | flags;
-  p->stack_size = stack_size;
+  p->dynstack = dynstack;
-  p->stack_bottom = (void *) ((char *) p + sizeof (*p));
   p->vra = vra;
   p->mra = mra;
   p->fp_offset = stack_top - fp;
-  memcpy (p->stack_bottom, sp, p->stack_size * sizeof (*p->stack_bottom));
+  p->stack_size = stack_size;
-  p->dynstack = dynstack;
+
-  p->flags = flags;
+  struct gc_mutator *mut = thread->mutator;
-  return scm_cell (scm_tc7_vm_cont, (scm_t_bits) p);
+  struct gc_heap *heap = gc_mutator_heap (mut);
+  for (size_t i = 0; i < stack_size; i++)
+    {
+      union scm_vm_stack_element elt = sp[i];
+      p->stack_slice[i] = elt;
+      struct gc_conservative_ref maybe_ref = gc_conservative_ref (elt.as_bits);
+      struct gc_ref ref = gc_resolve_conservative_ref (heap, maybe_ref, 0);
+      if (!gc_ref_is_null (ref))
+        gc_pin_object (mut, ref);
     }
 
-SCM
+  return p;
+}
+
+struct scm_vm_cont *
 scm_i_capture_current_stack (void)
 {
   scm_thread *thread;
@@ -197,7 +205,7 @@ scm_i_capture_current_stack (void)
   thread = SCM_I_CURRENT_THREAD;
   vp = &thread->vm;
 
-  return capture_stack (vp->stack_top, vp->fp, vp->sp, vp->ip, NULL,
+  return capture_stack (thread, vp->stack_top, vp->fp, vp->sp, vp->ip, NULL,
                         scm_dynstack_capture_all (&thread->dynstack),
                         0);
 }
@@ -1089,7 +1097,7 @@ reinstate_continuation_x (scm_thread *thread, SCM cont)
   argv = alloca (n * sizeof (*argv));
   memcpy (argv, vp->sp, n * sizeof (*argv));
 
-  cp = SCM_VM_CONT_DATA (continuation->vm_cont);
+  cp = continuation->vm_cont;
 
   gc_inhibit_preemption (thread->mutator);
   /* We know that there is enough space for the continuation, because we
@@ -1097,8 +1105,8 @@ reinstate_continuation_x (scm_thread *thread, SCM cont)
      since the capture, so we may have to re-link the frame
      pointers.  */
   memcpy (vp->stack_top - cp->stack_size,
-          cp->stack_bottom,
+          cp->stack_slice,
-          cp->stack_size * sizeof (*cp->stack_bottom));
+          cp->stack_size * sizeof (cp->stack_slice[0]));
   vp->fp = vp->stack_top - cp->fp_offset;
   vm_restore_sp (vp, vp->stack_top - cp->stack_size);
   gc_reallow_preemption (thread->mutator);
@@ -1125,14 +1133,16 @@ capture_continuation (scm_thread *thread)
   if (mra == scm_jit_return_to_interpreter_trampoline)
     mra = NULL;
 #endif
-  SCM vm_cont = capture_stack (vp->stack_top,
+  struct scm_vm_cont *cont =
+    capture_stack (thread,
+                   vp->stack_top,
                    SCM_FRAME_DYNAMIC_LINK (vp->fp),
                    SCM_FRAME_PREVIOUS_SP (vp->fp),
                    SCM_FRAME_VIRTUAL_RETURN_ADDRESS (vp->fp),
                    mra,
                    scm_dynstack_capture_all (&thread->dynstack),
                    0);
-  return scm_i_make_continuation (thread, vm_cont);
+  return scm_i_make_continuation (thread, cont);
 }
 
 static uint8_t*
@@ -1140,11 +1150,11 @@ compose_continuation (scm_thread *thread, SCM cont)
 {
   struct scm_vm *vp = &thread->vm;
   size_t nargs;
-  struct scm_vm_cont *cp;
+  struct scm_vm_cont *cp = scm_to_vm_cont (cont);
   union scm_vm_stack_element *args;
   ptrdiff_t old_fp_offset;
 
-  if (SCM_UNLIKELY (! SCM_VM_CONT_REWINDABLE_P (cont)))
+  if (SCM_UNLIKELY (!scm_vm_cont_is_rewindable (cont)))
     scm_wrong_type_arg_msg (NULL, 0, cont, "resumable continuation");
 
 #if ENABLE_JIT
@@ -1157,7 +1167,7 @@ compose_continuation (scm_thread *thread, SCM cont)
   args = alloca (nargs * sizeof (*args));
   memcpy (args, vp->sp, nargs * sizeof (*args));
 
-  cp = SCM_VM_CONT_DATA (cont);
+  cp = scm_to_vm_cont (cont);
 
   old_fp_offset = vp->stack_top - vp->fp;
 
@@ -1165,8 +1175,8 @@ compose_continuation (scm_thread *thread, SCM cont)
 
   gc_inhibit_preemption (thread->mutator);
   memcpy (vp->fp - cp->stack_size,
-          cp->stack_bottom,
+          cp->stack_slice,
-          cp->stack_size * sizeof (*cp->stack_bottom));
+          cp->stack_size * sizeof (cp->stack_slice[0]));
   vp->fp -= cp->fp_offset;
   vp->ip = cp->vra;
   gc_reallow_preemption (thread->mutator);
@@ -1242,14 +1252,14 @@ foreign_call (scm_thread *thread, SCM cif, SCM pointer)
 }
 
 static SCM
-capture_delimited_continuation (struct scm_vm *vp,
+capture_delimited_continuation (scm_thread *thread,
+                                struct scm_vm *vp,
                                 union scm_vm_stack_element *saved_fp,
                                 uint8_t *saved_mra,
                                 jmp_buf *saved_registers,
                                 scm_t_dynstack *dynstack,
                                 jmp_buf *current_registers)
 {
-  SCM vm_cont;
   uint32_t flags;
   union scm_vm_stack_element *base_fp;
 
@@ -1278,10 +1288,11 @@ capture_delimited_continuation (struct scm_vm *vp,
   /* Capture from the base_fp to the top thunk application frame.  Don't
      capture values from the most recent frame, as they are the abort
      args.  */
-  vm_cont = capture_stack (base_fp, vp->fp, vp->fp, vp->ip,
+  struct scm_vm_cont *vm_cont =
-                           saved_mra, dynstack, flags);
+    capture_stack (thread, base_fp, vp->fp, vp->fp, vp->ip, saved_mra,
+                   dynstack, flags);
 
-  return scm_i_make_composable_continuation (vm_cont);
+  return scm_i_make_composable_continuation (scm_from_vm_cont (vm_cont));
 }
 
 void
@@ -1401,8 +1412,9 @@ abort_to_prompt (scm_thread *thread, uint8_t *saved_mra)
       scm_t_dynstack *captured;
 
       captured = scm_dynstack_capture (dynstack, SCM_DYNSTACK_NEXT (prompt));
-      cont = capture_delimited_continuation (vp, fp, saved_mra, registers,
+      cont = capture_delimited_continuation (thread, vp, fp, saved_mra,
-                                             captured, thread->vm.registers);
+                                             registers, captured,
+                                             thread->vm.registers);
     }
 
   /* Unwind.  */

libguile/vm.h

@@ -27,6 +27,7 @@
 #endif
 
 #include <libguile/gc.h>
+#include <libguile/frames.h>
 #include <libguile/programs.h>
 
 #define SCM_VM_REGULAR_ENGINE 0
@@ -90,10 +91,17 @@ SCM_API void scm_c_set_default_vm_engine_x (int engine);
 SCM_INTERNAL void scm_i_vm_prepare_stack (struct scm_vm *vp);
 SCM_INTERNAL void scm_i_vm_free_stack (struct scm_vm *vp);
 
-#define SCM_F_VM_CONT_PARTIAL 0x1
+#ifdef BUILDING_LIBGUILE
-#define SCM_F_VM_CONT_REWINDABLE 0x2
+
+#define SCM_F_VM_CONT_PARTIAL 0x100
+#define SCM_F_VM_CONT_REWINDABLE 0x200
 
 struct scm_vm_cont {
+  /* vmcont tc7 in low 8 bits, partial and/or rewindable flags above.  */
+  scm_t_bits tag_and_flags;
+  /* Saved dynamic stack, with prompts relocated to record saved SP/FP
+     offsets from the stack top of this scm_vm_cont.  */
+  scm_t_dynstack *dynstack;
   /* IP of newest frame.  */
   uint32_t *vra;
   /* Machine code corresponding to IP.  */
@@ -104,28 +112,52 @@ struct scm_vm_cont {
      the newest frame.  */
   ptrdiff_t stack_size;
   /* Stack bottom, which also keeps saved stack alive for GC.  */
-  union scm_vm_stack_element *stack_bottom;
+  union scm_vm_stack_element stack_slice[];
-  /* Saved dynamic stack, with prompts relocated to record saved SP/FP
-     offsets from the stack top of this scm_vm_cont.  */
-  scm_t_dynstack *dynstack;
-  /* See the continuation is partial and/or rewindable.  */
-  uint32_t flags;
 };
 
-#define SCM_VM_CONT_P(OBJ)	(SCM_HAS_TYP7 (OBJ, scm_tc7_vm_cont))
+static inline int
-#define SCM_VM_CONT_DATA(CONT)	((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT))
+scm_is_vm_cont (SCM x)
-#define SCM_VM_CONT_PARTIAL_P(CONT) (SCM_VM_CONT_DATA (CONT)->flags & SCM_F_VM_CONT_PARTIAL)
+{
-#define SCM_VM_CONT_REWINDABLE_P(CONT) (SCM_VM_CONT_DATA (CONT)->flags & SCM_F_VM_CONT_REWINDABLE)
+  return SCM_HAS_TYP7 (x, scm_tc7_vm_cont);
+}
 
-SCM_API SCM scm_load_compiled_with_vm (SCM file);
+static inline struct scm_vm_cont *
+scm_to_vm_cont (SCM cont)
+{
+  if (!scm_is_vm_cont (cont)) abort ();
+  return (struct scm_vm_cont *) SCM_UNPACK_POINTER (cont);
+}
 
-SCM_INTERNAL SCM scm_i_call_with_current_continuation (SCM proc);
+static inline SCM
-SCM_INTERNAL SCM scm_i_capture_current_stack (void);
+scm_from_vm_cont (struct scm_vm_cont *cont)
-SCM_INTERNAL void scm_i_vm_abort (SCM *tag_and_argv, size_t n) SCM_NORETURN;
+{
-SCM_INTERNAL void scm_i_vm_emergency_abort (SCM *tag_and_argv, size_t n) SCM_NORETURN;
+  return SCM_PACK_POINTER (cont);
+}
+
+static inline int
+scm_vm_cont_is_partial (SCM cont)
+{
+  return scm_to_vm_cont (cont)->tag_and_flags & SCM_F_VM_CONT_PARTIAL;
+}
+
+static inline int
+scm_vm_cont_is_rewindable (SCM cont)
+{
+  return scm_to_vm_cont (cont)->tag_and_flags & SCM_F_VM_CONT_REWINDABLE;
+}
+
+SCM_INTERNAL struct scm_vm_cont *scm_i_capture_current_stack (void);
 SCM_INTERNAL int scm_i_vm_cont_to_frame (SCM cont, struct scm_frame *frame);
 SCM_INTERNAL void scm_i_vm_cont_print (SCM x, SCM port,
                                        scm_print_state *pstate);
+
+#endif /* BUILDING_LIBGUILE */
+
+SCM_INTERNAL void scm_i_vm_abort (SCM *tag_and_argv, size_t n) SCM_NORETURN;
+SCM_INTERNAL void scm_i_vm_emergency_abort (SCM *tag_and_argv, size_t n) SCM_NORETURN;
+SCM_API SCM scm_load_compiled_with_vm (SCM file);
+
+SCM_INTERNAL SCM scm_i_call_with_current_continuation (SCM proc);
 SCM_INTERNAL int scm_i_vm_is_boot_continuation_code (uint32_t *ip);
 SCM_INTERNAL void scm_bootstrap_vm (void);
 SCM_INTERNAL void scm_init_vm (void);