rewinding prompts works

* libguile/control.h (SCM_PROMPT_HANDLER): Remove, it was unused.
  (SCM_PROMPT_DYNWINDS): Rename from SCM_PROMPT_DYNENV.

* libguile/control.c: (scm_c_make_prompt): Take another arg, the winds
  that are to be in place for the prompt. Fix allocation to be 4 words
  instead of 5 (the handler was never used).

* libguile/eval.c (eval):
* libguile/throw.c (pre_init_catch): Adapt to scm_c_make_prompt change.

* libguile/vm-i-system.c (partial-cont-call): Grovel the new elements of
  the wind list in order to call setjmp() on the new prompts. Pass
  cookie to vm_reinstate_partial_continuation.
  (prompt): Adapt to scm_c_make_prompt change.

* libguile/vm.c (vm_reinstate_partial_continuation): Take a cookie arg,
  used when winding captured prompts onto the stack. Winding a prompt
  implies making a new prompt, actually -- with new registers, a new
  jump buffer, new winds, etc.

* test-suite/tests/control.test ("rewinding prompts"): Add a test for
  rewinding prompts.

libguile/control.c

@@ -33,16 +33,15 @@ SCM scm_sys_default_prompt_tag;
 
 SCM
 scm_c_make_prompt (SCM k, SCM *fp, SCM *sp, scm_t_uint8 *abort_ip,
-                   scm_t_uint8 escape_only_p, scm_t_int64 vm_cookie)
+                   scm_t_uint8 escape_only_p, scm_t_int64 vm_cookie,
+                   SCM winds)
 {
   scm_t_bits tag;
-  SCM ret;
   struct scm_prompt_registers *regs;
 
   tag = scm_tc7_prompt;
   if (escape_only_p)
     tag |= (SCM_F_PROMPT_ESCAPE<<8);
-  ret = scm_words (tag, 5);
 
   regs = scm_gc_malloc_pointerless (sizeof (*regs), "prompt registers");
   regs->fp = fp;
@@ -50,11 +49,8 @@ scm_c_make_prompt (SCM k, SCM *fp, SCM *sp, scm_t_uint8 *abort_ip,
   regs->ip = abort_ip;
   regs->cookie = vm_cookie;
 
-  SCM_SET_CELL_OBJECT (ret, 1, k);
+  return scm_double_cell (tag, SCM_UNPACK (k), (scm_t_bits)regs, 
-  SCM_SET_CELL_WORD (ret, 2, (scm_t_bits)regs);
+                          SCM_UNPACK (winds));
-  SCM_SET_CELL_OBJECT (ret, 3, scm_i_dynwinds ());
-
-  return ret;
 }
 
 /* Only to be called if the SCM_PROMPT_SETJMP returns 1 */

libguile/control.h

@@ -27,8 +27,7 @@
 #define SCM_PROMPT_ESCAPE_P(x)	(SCM_PROMPT_FLAGS (x) & SCM_F_PROMPT_ESCAPE)
 #define SCM_PROMPT_TAG(x)	(SCM_CELL_OBJECT ((x), 1))
 #define SCM_PROMPT_REGISTERS(x)	((struct scm_prompt_registers*)SCM_CELL_WORD ((x), 2))
-#define SCM_PROMPT_DYNENV(x)	(SCM_CELL_OBJECT ((x), 3))
+#define SCM_PROMPT_DYNWINDS(x)	(SCM_CELL_OBJECT ((x), 3))
-#define SCM_PROMPT_HANDLER(x)	(SCM_CELL_OBJECT ((x), 4))
 
 #define SCM_PROMPT_SETJMP(p)	(SCM_I_SETJMP (SCM_PROMPT_REGISTERS (p)->regs))
 
@@ -48,7 +47,8 @@ SCM_INTERNAL SCM scm_sys_default_prompt_tag;
 SCM_INTERNAL SCM scm_c_make_prompt (SCM k, SCM *fp, SCM *sp,
                                     scm_t_uint8 *abort_ip,
                                     scm_t_uint8 escape_only_p,
-                                    scm_t_int64 vm_cookie);
+                                    scm_t_int64 vm_cookie,
+                                    SCM winds);
 SCM_INTERNAL SCM scm_i_prompt_pop_abort_args_x (SCM prompt);
 
 SCM_INTERNAL void scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv,

libguile/eval.c

@@ -432,7 +432,7 @@ eval (SCM x, SCM env)
         vm = scm_the_vm ();
         prompt = scm_c_make_prompt (eval (CAR (mx), env), SCM_VM_DATA (vm)->fp,
                                     SCM_VM_DATA (vm)->sp, SCM_VM_DATA (vm)->ip,
-                                    0, -1);
+                                    0, -1, scm_i_dynwinds ());
         handler = eval (CDDR (mx), env);
         scm_i_set_dynwinds (scm_cons (prompt, scm_i_dynwinds ()));
 

libguile/throw.c

@@ -512,8 +512,8 @@ pre_init_catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
   vm = scm_the_vm ();
   prompt = scm_c_make_prompt (scm_fluid_ref (scm_sys_default_prompt_tag),
                               SCM_VM_DATA (vm)->fp, SCM_VM_DATA (vm)->sp,
-                              SCM_VM_DATA (vm)->ip, 1, -1);
+                              SCM_VM_DATA (vm)->ip, 1, -1, scm_i_dynwinds ());
-  scm_i_set_dynwinds (scm_cons (prompt, scm_i_dynwinds ()));
+  scm_i_set_dynwinds (scm_cons (prompt, SCM_PROMPT_DYNWINDS (prompt)));
 
   if (SCM_PROMPT_SETJMP (prompt))
     {

libguile/vm-i-system.c

@@ -995,7 +995,7 @@ VM_DEFINE_INSTRUCTION (89, continuation_call, "continuation-call", 0, -1, 0)
 
 VM_DEFINE_INSTRUCTION (94, partial_cont_call, "partial-cont-call", 0, -1, 0)
 {
-  SCM vmcont, intwinds;
+  SCM vmcont, intwinds, prevwinds;
   POP (intwinds);
   POP (vmcont);
   SYNC_REGISTER ();
@@ -1003,7 +1003,18 @@ VM_DEFINE_INSTRUCTION (94, partial_cont_call, "partial-cont-call", 0, -1, 0)
     { finish_args = vmcont;
       goto vm_error_continuation_not_rewindable;
     }
-  vm_reinstate_partial_continuation (vm, vmcont, intwinds, sp + 1 - fp, fp);
+  prevwinds = scm_i_dynwinds ();
+  vm_reinstate_partial_continuation (vm, vmcont, intwinds, sp + 1 - fp, fp,
+                                     vm_cookie);
+
+  /* Rewind prompt jmpbuffers, if any. */
+  {
+    SCM winds = scm_i_dynwinds ();
+    for (; !scm_is_eq (winds, prevwinds); winds = scm_cdr (winds))
+      if (SCM_PROMPT_P (scm_car (winds)) && SCM_PROMPT_SETJMP (scm_car (winds)))
+        break;
+  }
+    
   CACHE_REGISTER ();
   program = SCM_FRAME_PROGRAM (fp);
   CACHE_PROGRAM ();
@@ -1480,8 +1491,9 @@ VM_DEFINE_INSTRUCTION (83, prompt, "prompt", 4, 2, 0)
 
   SYNC_REGISTER ();
   /* Push the prompt onto the dynamic stack. */
-  prompt = scm_c_make_prompt (k, fp, sp, ip + offset, escape_only_p, vm_cookie);
+  prompt = scm_c_make_prompt (k, fp, sp, ip + offset, escape_only_p, vm_cookie,
-  scm_i_set_dynwinds (scm_cons (prompt, scm_i_dynwinds ()));
+                              scm_i_dynwinds ());
+  scm_i_set_dynwinds (scm_cons (prompt, SCM_PROMPT_DYNWINDS (prompt)));
   if (SCM_PROMPT_SETJMP (prompt))
     {
       /* The prompt exited nonlocally. Cache the regs back from the vp, and go

libguile/vm.c

@@ -231,7 +231,7 @@ vm_abort (SCM vm, size_t n, scm_t_int64 vm_cookie)
 
 static void
 vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM intwinds,
-                                   size_t n, SCM *argv)
+                                   size_t n, SCM *argv, scm_t_int64 vm_cookie)
 {
   struct scm_vm *vp;
   struct scm_vm_cont *cp;
@@ -267,8 +267,6 @@ vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM intwinds,
   vp->fp = RELOC (cp->fp);
   vp->ip = cp->mvra;
 
-#undef RELOC
-
   /* now push args. ip is in a MV context. */
   for (i = 0; i < n; i++)
     {
@@ -278,14 +276,32 @@ vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM intwinds,
   vp->sp++;
   *vp->sp = scm_from_size_t (n);
 
-  /* Finally, rewind the dynamic state. */
+  /* Finally, rewind the dynamic state.
+
+     We have to treat prompts specially, because we could be rewinding the
+     dynamic state from a different thread, or just a different position on the
+     C and/or VM stack -- so we need to reset the jump buffers so that an abort
+     comes back here, with appropriately adjusted sp and fp registers. */
   {
     long delta = 0;
     SCM newwinds = scm_i_dynwinds ();
     for (; scm_is_pair (intwinds); intwinds = scm_cdr (intwinds), delta--)
-      newwinds = scm_cons (scm_car (intwinds), newwinds);
+      {
+        SCM x = scm_car (intwinds);
+        if (SCM_PROMPT_P (x))
+          /* the jmpbuf will be reset by our caller */
+          x = scm_c_make_prompt (SCM_PROMPT_TAG (x),
+                                 RELOC (SCM_PROMPT_REGISTERS (x)->fp),
+                                 RELOC (SCM_PROMPT_REGISTERS (x)->sp),
+                                 SCM_PROMPT_REGISTERS (x)->ip,
+                                 SCM_PROMPT_ESCAPE_P (x),
+                                 vm_cookie,
+                                 newwinds);
+        newwinds = scm_cons (x, newwinds);
+      }
     scm_dowinds (newwinds, delta);
   }
+#undef RELOC
 }
 
 

test-suite/tests/control.test

@@ -204,3 +204,14 @@
       (equal? (k) 1))
     (pass-if "post"
       (equal? (fluid-ref fl) 0))))
+
+(with-test-prefix "rewinding prompts"
+  (pass-if "nested prompts"
+    (let ((k (% 'a
+                (% 'b
+                   (begin
+                     (abort 'a)
+                     (abort 'b #t))
+                   (lambda (k x) x))
+                (lambda (k) k))))
+      (k))))