Add suspendable-continuation?

* doc/ref/api-control.texi (Prompt Primitives): Document
  suspendable-continuation?.
* libguile/control.c (scm_suspendable_continuation_p): New procedure.
  (scm_init_ice_9_control): New extension procedure, defines
  suspendable-continuation?.
  (scm_init_control): Register scm_init_ice_9_control.
* libguile/eval.c (eval):
* libguile/throw.c (catch):
* libguile/continuations.c (scm_i_make_continuation): Restore resumable
  prompt cookie after continuation invocation.
* libguile/vm.c (scm_call_n): Arrange to set resumable_prompt_cookie
  during invocation of VM.
* libguile/vm.h (struct scm_vm): Add resumable_prompt_cookie member.
* module/ice-9/control.scm: Export suspendable-continuation?.
* test-suite/tests/control.test ("suspendable-continuation?"): New
  test.

doc/ref/api-control.texi

@@ -628,6 +628,33 @@ This is equivalent to
 @code{(call/ec (lambda (@var{k}) @var{body} @dots{}))}.
 @end deffn
 
+Additionally there is another helper primitive exported by @code{(ice-9
+control)}, so load up that module for @code{suspendable-continuation?}:
+
+@example
+(use-modules (ice-9 control))
+@end example
+
+@deffn {Scheme Procedure} suspendable-continuation? tag
+Return @code{#t} if a call to @code{abort-to-prompt} with the prompt tag
+@var{tag} would produce a delimited continuation that could be resumed
+later.
+
+Almost all continuations have this property.  The exception is where
+some code between the @code{call-with-prompt} and the
+@code{abort-to-prompt} recursed through C for some reason, the
+@code{abort-to-prompt} will succeed but any attempt to resume the
+continuation (by calling it) would fail.  This is because composing a
+saved continuation with the current continuation involves relocating the
+stack frames that were saved from the old stack onto a (possibly) new
+position on the new stack, and Guile can only do this for stack frames
+that it created for Scheme code, not stack frames created by the C
+compiler.  It's a bit gnarly but if you stick with Scheme, you won't
+have any problem.
+
+If no prompt is found with the given tag, this procedure just returns
+@code{#f}.
+@end deffn
 
 @node Shift and Reset
 @subsubsection Shift, Reset, and All That

libguile/continuations.c

@@ -121,6 +121,7 @@ scm_i_make_continuation (int *first, struct scm_vm *vp, SCM vm_cont)
   SCM cont;
   scm_t_contregs *continuation;
   long stack_size;
+  const void *saved_cookie;
   SCM_STACKITEM * src;
 
   SCM_FLUSH_REGISTER_WINDOWS;
@@ -138,6 +139,7 @@ scm_i_make_continuation (int *first, struct scm_vm *vp, SCM vm_cont)
   memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size);
   continuation->vp = vp;
   continuation->vm_cont = vm_cont;
+  saved_cookie = vp->resumable_prompt_cookie;
 
   SCM_NEWSMOB (cont, tc16_continuation, continuation);
 
@@ -161,6 +163,7 @@ scm_i_make_continuation (int *first, struct scm_vm *vp, SCM vm_cont)
     }
   else
     {
+      vp->resumable_prompt_cookie = saved_cookie;
       scm_gc_after_nonlocal_exit ();
       return SCM_UNDEFINED;
     }

libguile/control.c

@@ -205,10 +205,35 @@ SCM_DEFINE (scm_abort_to_prompt_star, "abort-to-prompt*", 2, 0, 0,
 }
 #undef FUNC_NAME
 
+static SCM
+scm_suspendable_continuation_p (SCM tag)
+{
+  scm_t_dynstack_prompt_flags flags;
+  scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+  scm_i_jmp_buf *registers;
+
+  if (scm_dynstack_find_prompt (&thread->dynstack, tag, &flags,
+                                NULL, NULL, NULL, &registers))
+    return scm_from_bool (registers == thread->vp->resumable_prompt_cookie);
+
+  return SCM_BOOL_F;
+}
+
+static void
+scm_init_ice_9_control (void *unused)
+{
+  scm_c_define_gsubr ("suspendable-continuation?", 1, 0, 0,
+                      scm_suspendable_continuation_p);
+}
+
 void
 scm_init_control (void)
 {
 #include "libguile/control.x"
+
+  scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+                            "scm_init_ice_9_control", scm_init_ice_9_control,
+			    NULL);
 }
 
 /*

libguile/eval.c

@@ -425,6 +425,7 @@ eval (SCM x, SCM env)
         struct scm_vm *vp;
         SCM k, handler, res;
         scm_i_jmp_buf registers;
+        const void *prev_cookie;
         scm_t_ptrdiff saved_stack_depth;
 
         k = EVAL1 (CAR (mx), env);
@@ -442,9 +443,11 @@ eval (SCM x, SCM env)
                                   vp->ip,
                                   &registers);
 
+        prev_cookie = vp->resumable_prompt_cookie;
         if (SCM_I_SETJMP (registers))
           {
             /* The prompt exited nonlocally. */
+            vp->resumable_prompt_cookie = prev_cookie;
             scm_gc_after_nonlocal_exit ();
             proc = handler;
             args = scm_i_prompt_pop_abort_args_x (vp, saved_stack_depth);

libguile/throw.c

@@ -78,6 +78,7 @@ catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
   scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack;
   scm_t_dynamic_state *dynamic_state = SCM_I_CURRENT_THREAD->dynamic_state;
   scm_i_jmp_buf registers;
+  const void *prev_cookie;
   scm_t_ptrdiff saved_stack_depth;
 
   if (!scm_is_eq (tag, SCM_BOOL_T) && !scm_is_symbol (tag))
@@ -102,6 +103,7 @@ catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
   scm_c_vector_set_x (eh, 3, pre_unwind_handler);
 
   vp = scm_the_vm ();
+  prev_cookie = vp->resumable_prompt_cookie;
   saved_stack_depth = vp->stack_top - vp->sp;
 
   /* Push the prompt and exception handler onto the dynamic stack. */
@@ -120,6 +122,7 @@ catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
       /* A non-local return.  */
       SCM args;
 
+      vp->resumable_prompt_cookie = prev_cookie;
       scm_gc_after_nonlocal_exit ();
 
       /* FIXME: We know where the args will be on the stack; we could

libguile/vm.c

@@ -1234,8 +1234,11 @@ scm_call_n (SCM proc, SCM *argv, size_t nargs)
 
   {
     scm_i_jmp_buf registers;
-    int resume = SCM_I_SETJMP (registers);
-      
+    int resume;
+    const void *prev_cookie = vp->resumable_prompt_cookie;
+    SCM ret;
+
+    resume = SCM_I_SETJMP (registers);
     if (SCM_UNLIKELY (resume))
       {
         scm_gc_after_nonlocal_exit ();
@@ -1243,7 +1246,11 @@ scm_call_n (SCM proc, SCM *argv, size_t nargs)
         vm_dispatch_abort_hook (vp);
       }
 
-    return vm_engines[vp->engine](thread, vp, &registers, resume);
+    vp->resumable_prompt_cookie = &registers;
+    ret = vm_engines[vp->engine](thread, vp, &registers, resume);
+    vp->resumable_prompt_cookie = prev_cookie;
+
+    return ret;
   }
 }
 

libguile/vm.h

@@ -47,6 +47,7 @@ struct scm_vm {
   union scm_vm_stack_element *stack_top; /* highest address in allocated stack */
   SCM overflow_handler_stack;   /* alist of max-stack-size -> thunk */
   SCM hooks[SCM_VM_NUM_HOOKS];	/* hooks */
+  const void *resumable_prompt_cookie; /* opaque cookie */
   int engine;                   /* which vm engine we're using */
 };
 

module/ice-9/control.scm

@@ -23,7 +23,11 @@
                default-prompt-tag make-prompt-tag)
   #:export (% abort shift reset shift* reset*
             call-with-escape-continuation call/ec
-            let-escape-continuation let/ec))
+            let-escape-continuation let/ec
+            suspendable-continuation?))
+
+(load-extension (string-append "libguile-" (effective-version))
+                "scm_init_ice_9_control")
 
 (define (abort . args)
   (apply abort-to-prompt (default-prompt-tag) args))

test-suite/tests/control.test

@@ -410,3 +410,30 @@
                                 (cons (car xs) (k (cdr xs))))))))
                 (reset* (lambda () (visit xs))))
               (traverse '(1 2 3 4 5))))))
+
+(with-test-prefix "suspendable-continuation?"
+  (let ((tag (make-prompt-tag)))
+    (pass-if "escape-only"
+      (call-with-prompt tag
+        (lambda ()
+          (suspendable-continuation? tag))
+        (lambda _ (error "unreachable"))))
+    (pass-if "full"
+      (call-with-prompt tag
+        (lambda ()
+          (suspendable-continuation? tag))
+        (lambda (k) (error "unreachable" k))))
+    (pass-if "escape-only with barrier"
+      (call-with-prompt tag
+        (lambda ()
+          (with-continuation-barrier
+           (lambda ()
+             (not (suspendable-continuation? tag)))))
+        (lambda _ (error "unreachable"))))
+    (pass-if "full with barrier"
+      (call-with-prompt tag
+        (lambda ()
+          (with-continuation-barrier
+           (lambda ()
+             (not (suspendable-continuation? tag)))))
+        (lambda (k) (error "unreachable" k))))))