[Guile-commits] 23/26: abort-to-prompt uses an intrinsic

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit e7778c62aa35ae10743cb4680df0bb3440163e26
Author: Andy Wingo <address@hidden>
Date:   Tue Jun 26 16:19:16 2018 +0200

    abort-to-prompt uses an intrinsic
    
    * libguile/control.h:
    * libguile/control.c (scm_i_make_composable_continuation): Rename from
      make_partial_continuation and expose internally.
      (scm_abort_to_prompt_star): Adapt to scm_i_vm_abort name change.
    * libguile/intrinsics.h (SCM_FOR_ALL_VM_INTRINSICS): Define
      abort_to_prompt intrinsic.
    * libguile/throw.c (abort_to_prompt): Adapt to scm_i_vm_abort name
      change.
    * libguile/vm-engine.c (abort): Use abort_to_prompt intrinsic.
    * libguile/vm.c (capture_delimited_continuation): Move here from
      control.c where it was named reify_partial_continuation.
      (scm_i_vm_abort): Move from control.c where it was named
      scm_c_abort (and only exposed internally).
      (abort_to_prompt): New intrinsic, replacing vm_abort.
    * libguile/vm.h: Add setjmp include and scm_i_vm_abort decl.
---
 libguile/control.c    | 110 ++------------------------------------
 libguile/control.h    |   6 +--
 libguile/intrinsics.h |   2 +
 libguile/throw.c      |   2 +-
 libguile/vm-engine.c  |   5 +-
 libguile/vm.c         | 144 +++++++++++++++++++++++++++++++++++++++++++-------
 libguile/vm.h         |   4 ++
 7 files changed, 138 insertions(+), 135 deletions(-)

diff --git a/libguile/control.c b/libguile/control.c
index df3a2dc..38378ae 100644
--- a/libguile/control.c
+++ b/libguile/control.c
@@ -74,8 +74,8 @@ static const uint32_t compose_continuation_code[] =
   };
 
 
-static SCM
-make_partial_continuation (SCM vm_cont)
+SCM
+scm_i_make_composable_continuation (SCM vmcont)
 {
   scm_t_bits nfree = 1;
   scm_t_bits flags = SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION;
@@ -83,113 +83,11 @@ make_partial_continuation (SCM vm_cont)
 
   ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2);
   SCM_SET_CELL_WORD_1 (ret, compose_continuation_code);
-  SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, vm_cont);
+  SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, vmcont);
 
   return ret;
 }
 
-static SCM
-reify_partial_continuation (struct scm_vm *vp,
-                            union scm_vm_stack_element *saved_fp,
-                            union scm_vm_stack_element *saved_sp,
-                            uint32_t *saved_ip,
-                            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;
-
-  flags = SCM_F_VM_CONT_PARTIAL;
-  /* If we are aborting to a prompt that has the same registers as those
-     of the abort, it means there are no intervening C frames on the
-     stack, and so the continuation can be relocated elsewhere on the
-     stack: it is rewindable.  */
-  if (saved_registers && saved_registers == current_registers)
-    flags |= SCM_F_VM_CONT_REWINDABLE;
-
-  /* Walk the stack until we find the first frame newer than saved_fp.
-     We will save the stack until that frame.  It used to be that we
-     could determine the stack base in O(1) time, but that's no longer
-     the case, since the thunk application doesn't occur where the
-     prompt is saved.  */
-  for (base_fp = vp->fp;
-       SCM_FRAME_DYNAMIC_LINK (base_fp) < saved_fp;
-       base_fp = SCM_FRAME_DYNAMIC_LINK (base_fp));
-
-  if (SCM_FRAME_DYNAMIC_LINK (base_fp) != saved_fp)
-    abort();
-
-  scm_dynstack_relocate_prompts (dynstack, vp->stack_top - base_fp);
-
-  /* Capture from the base_fp to the top thunk application frame. */
-  vm_cont = scm_i_vm_capture_stack (base_fp, vp->fp, vp->sp, vp->ip, dynstack,
-                                    flags);
-
-  return make_partial_continuation (vm_cont);
-}
-
-void
-scm_c_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv,
-             jmp_buf *current_registers)
-{
-  SCM cont;
-  scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack;
-  scm_t_bits *prompt;
-  scm_t_dynstack_prompt_flags flags;
-  ptrdiff_t fp_offset, sp_offset;
-  union scm_vm_stack_element *fp, *sp;
-  uint32_t *ip;
-  jmp_buf *registers;
-  size_t i;
-
-  prompt = scm_dynstack_find_prompt (dynstack, tag,
-                                     &flags, &fp_offset, &sp_offset, &ip,
-                                     &registers);
-
-  if (!prompt)
-    scm_misc_error ("abort", "Abort to unknown prompt", scm_list_1 (tag));
-
-  fp = vp->stack_top - fp_offset;
-  sp = vp->stack_top - sp_offset;
-
-  /* Only reify if the continuation referenced in the handler. */
-  if (flags & SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY)
-    cont = SCM_BOOL_F;
-  else
-    {
-      scm_t_dynstack *captured;
-
-      captured = scm_dynstack_capture (dynstack, SCM_DYNSTACK_NEXT (prompt));
-      cont = reify_partial_continuation (vp, fp, sp, ip, registers, captured,
-                                         current_registers);
-    }
-
-  /* Unwind.  */
-  scm_dynstack_unwind (dynstack, prompt);
-
-  /* Restore VM regs */
-  vp->fp = fp;
-  vp->sp = sp - n - 1;
-  vp->ip = ip;
-
-  /* Since we're jumping down, we should always have enough space.  */
-  if (vp->sp < vp->stack_limit)
-    abort ();
-
-  /* Push vals */
-  vp->sp[n].as_scm = cont;
-  for (i = 0; i < n; i++)
-    vp->sp[n - i - 1].as_scm = argv[i];
-
-  /* Jump! */
-  longjmp (*registers, 1);
-
-  /* Shouldn't get here */
-  abort ();
-}
-
 SCM_DEFINE (scm_abort_to_prompt_star, "abort-to-prompt*", 2, 0, 0,
             (SCM tag, SCM args),
             "Abort to the nearest prompt with tag @var{tag}, yielding the\n"
@@ -205,7 +103,7 @@ SCM_DEFINE (scm_abort_to_prompt_star, "abort-to-prompt*", 
2, 0, 0,
   for (i = 0; i < n; i++, args = scm_cdr (args))
     argv[i] = scm_car (args);
 
-  scm_c_abort (&SCM_I_CURRENT_THREAD->vm, tag, n, argv, NULL);
+  scm_i_vm_abort (&SCM_I_CURRENT_THREAD->vm, tag, n, argv, NULL);
 
   /* Oh, what, you're still here? The abort must have been reinstated. 
Actually,
      that's quite impossible, given that we're already in C-land here, so...
diff --git a/libguile/control.h b/libguile/control.h
index c2bb5b5..4f64f41 100644
--- a/libguile/control.h
+++ b/libguile/control.h
@@ -20,16 +20,14 @@
 #ifndef SCM_CONTROL_H
 #define SCM_CONTROL_H
 
-#include <setjmp.h>
-
 #include "libguile/scm.h"
 
 
 SCM_INTERNAL SCM scm_i_prompt_pop_abort_args_x (struct scm_vm *vp,
                                                 ptrdiff_t saved_stack_depth);
 
-SCM_INTERNAL void scm_c_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv,
-                               jmp_buf *registers) SCM_NORETURN;
+SCM_INTERNAL SCM scm_i_make_composable_continuation (SCM vmcont);
+
 SCM_INTERNAL SCM scm_abort_to_prompt_star (SCM tag, SCM args) SCM_NORETURN;
 
 
diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h
index 894db5a..a46f731 100644
--- a/libguile/intrinsics.h
+++ b/libguile/intrinsics.h
@@ -57,6 +57,7 @@ typedef void (*scm_t_thread_scm_noreturn_intrinsic) 
(scm_thread*, SCM) SCM_NORET
 typedef SCM (*scm_t_scm_from_thread_regs_intrinsic) (scm_thread*, jmp_buf*);
 typedef void (*scm_t_thread_regs_scm_intrinsic) (scm_thread*, jmp_buf*, SCM);
 typedef int (*scm_t_int_from_scm_intrinsic) (SCM);
+typedef void (*scm_t_thread_regs_intrinsic) (scm_thread*, jmp_buf*);
 
 #define SCM_FOR_ALL_VM_INTRINSICS(M) \
   M(scm_from_scm_scm, add, "add", ADD) \
@@ -111,6 +112,7 @@ typedef int (*scm_t_int_from_scm_intrinsic) (SCM);
   M(scm_from_thread_regs, capture_continuation, "capture-continuation", 
CAPTURE_CONTINUATION) \
   M(thread_regs_scm, compose_continuation, "compose-continuation", 
COMPOSE_CONTINUATION) \
   M(int_from_scm, rest_arg_length, "rest-arg-length", REST_ARG_LENGTH) \
+  M(thread_regs, abort_to_prompt, "abort-to-prompt", ABORT_TO_PROMPT) \
   /* Add new intrinsics here; also update scm_bootstrap_intrinsics.  */
 
 enum scm_vm_intrinsic
diff --git a/libguile/throw.c b/libguile/throw.c
index 1ad7294..7372ccb 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -195,7 +195,7 @@ abort_to_prompt (SCM prompt_tag, SCM tag, SCM args)
   for (i = 1; i < n; i++, args = scm_cdr (args))
     argv[i] = scm_car (args);
 
-  scm_c_abort (&SCM_I_CURRENT_THREAD->vm, prompt_tag, n, argv, NULL);
+  scm_i_vm_abort (&SCM_I_CURRENT_THREAD->vm, prompt_tag, n, argv, NULL);
 
   /* Oh, what, you're still here? The abort must have been reinstated. 
Actually,
      that's quite impossible, given that we're already in C-land here, so...
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 9ff4711..7fc5499 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -781,15 +781,12 @@ VM_NAME (scm_thread *thread, jmp_buf *registers, int 
resume)
    */
   VM_DEFINE_OP (16, abort, "abort", OP1 (X32))
     {
-      uint32_t nlocals = FRAME_LOCALS_COUNT ();
-
-      ASSERT (nlocals >= 2);
       /* FIXME: Really we should capture the caller's registers.  Until
          then, manually advance the IP so that when the prompt resumes,
          it continues with the next instruction.  */
       ip++;
       SYNC_IP ();
-      vm_abort (VP, FP_REF (1), nlocals - 2, registers);
+      scm_vm_intrinsics.abort_to_prompt (thread, registers);
 
       /* vm_abort should not return */
       abort ();
diff --git a/libguile/vm.c b/libguile/vm.c
index 58badfa..29f33e2 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -303,26 +303,6 @@ static void vm_dispatch_abort_hook (struct scm_vm *vp)
                            vp->sp, SCM_FRAME_NUM_LOCALS (vp->fp, vp->sp) - 1);
 }
 
-static void
-vm_abort (struct scm_vm *vp, SCM tag, size_t nargs,
-          jmp_buf *current_registers) SCM_NORETURN;
-
-static void
-vm_abort (struct scm_vm *vp, SCM tag, size_t nargs,
-          jmp_buf *current_registers)
-{
-  size_t i;
-  SCM *argv;
-  
-  argv = alloca (nargs * sizeof (SCM));
-  for (i = 0; i < nargs; i++)
-    argv[i] = vp->sp[nargs - i - 1].as_scm;
-
-  vp->sp = vp->fp;
-
-  scm_c_abort (vp, tag, nargs, argv, current_registers);
-}
-
 
 /*
  * VM Error Handling
@@ -1314,6 +1294,129 @@ rest_arg_length (SCM x)
   return len;
 }
 
+static SCM
+capture_delimited_continuation (struct scm_vm *vp,
+                                union scm_vm_stack_element *saved_fp,
+                                union scm_vm_stack_element *saved_sp,
+                                uint32_t *saved_ip,
+                                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;
+
+  flags = SCM_F_VM_CONT_PARTIAL;
+  /* If we are aborting to a prompt that has the same registers as those
+     of the abort, it means there are no intervening C frames on the
+     stack, and so the continuation can be relocated elsewhere on the
+     stack: it is rewindable.  */
+  if (saved_registers && saved_registers == current_registers)
+    flags |= SCM_F_VM_CONT_REWINDABLE;
+
+  /* Walk the stack until we find the first frame newer than saved_fp.
+     We will save the stack until that frame.  It used to be that we
+     could determine the stack base in O(1) time, but that's no longer
+     the case, since the thunk application doesn't occur where the
+     prompt is saved.  */
+  for (base_fp = vp->fp;
+       SCM_FRAME_DYNAMIC_LINK (base_fp) < saved_fp;
+       base_fp = SCM_FRAME_DYNAMIC_LINK (base_fp));
+
+  if (SCM_FRAME_DYNAMIC_LINK (base_fp) != saved_fp)
+    abort();
+
+  scm_dynstack_relocate_prompts (dynstack, vp->stack_top - base_fp);
+
+  /* Capture from the base_fp to the top thunk application frame. */
+  vm_cont = scm_i_vm_capture_stack (base_fp, vp->fp, vp->sp, vp->ip, dynstack,
+                                    flags);
+
+  return scm_i_make_composable_continuation (vm_cont);
+}
+
+void
+scm_i_vm_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv,
+                jmp_buf *current_registers)
+{
+  SCM cont;
+  scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack;
+  scm_t_bits *prompt;
+  scm_t_dynstack_prompt_flags flags;
+  ptrdiff_t fp_offset, sp_offset;
+  union scm_vm_stack_element *fp, *sp;
+  uint32_t *ip;
+  jmp_buf *registers;
+  size_t i;
+
+  prompt = scm_dynstack_find_prompt (dynstack, tag,
+                                     &flags, &fp_offset, &sp_offset, &ip,
+                                     &registers);
+
+  if (!prompt)
+    scm_misc_error ("abort", "Abort to unknown prompt", scm_list_1 (tag));
+
+  fp = vp->stack_top - fp_offset;
+  sp = vp->stack_top - sp_offset;
+
+  /* Only reify if the continuation referenced in the handler. */
+  if (flags & SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY)
+    cont = SCM_BOOL_F;
+  else
+    {
+      scm_t_dynstack *captured;
+
+      captured = scm_dynstack_capture (dynstack, SCM_DYNSTACK_NEXT (prompt));
+      cont = capture_delimited_continuation (vp, fp, sp, ip, registers, 
captured,
+                                             current_registers);
+    }
+
+  /* Unwind.  */
+  scm_dynstack_unwind (dynstack, prompt);
+
+  /* Restore VM regs */
+  vp->fp = fp;
+  vp->sp = sp - n - 1;
+  vp->ip = ip;
+
+  /* Since we're jumping down, we should always have enough space.  */
+  if (vp->sp < vp->stack_limit)
+    abort ();
+
+  /* Push vals */
+  vp->sp[n].as_scm = cont;
+  for (i = 0; i < n; i++)
+    vp->sp[n - i - 1].as_scm = argv[i];
+
+  /* Jump! */
+  longjmp (*registers, 1);
+
+  /* Shouldn't get here */
+  abort ();
+}
+
+static void
+abort_to_prompt (scm_thread *thread, jmp_buf *current_registers)
+{
+  struct scm_vm *vp = &thread->vm;
+  SCM tag;
+  size_t nargs, i;
+  SCM *argv;
+
+  tag = SCM_FRAME_LOCAL (vp->fp, 1);
+  nargs = frame_locals_count (thread) - 2;
+
+  /* FIXME: Avoid this alloca.  */
+  argv = alloca (nargs * sizeof (SCM));
+  for (i = 0; i < nargs; i++)
+    argv[i] = vp->sp[nargs - i - 1].as_scm;
+
+  vp->sp = vp->fp;
+
+  scm_i_vm_abort (vp, tag, nargs, argv, current_registers);
+}
+
 SCM
 scm_call_n (SCM proc, SCM *argv, size_t nargs)
 {
@@ -1661,6 +1764,7 @@ scm_bootstrap_vm (void)
   scm_vm_intrinsics.capture_continuation = capture_continuation;
   scm_vm_intrinsics.compose_continuation = compose_continuation;
   scm_vm_intrinsics.rest_arg_length = rest_arg_length;
+  scm_vm_intrinsics.abort_to_prompt = abort_to_prompt;
 
   sym_vm_run = scm_from_latin1_symbol ("vm-run");
   sym_vm_error = scm_from_latin1_symbol ("vm-error");
diff --git a/libguile/vm.h b/libguile/vm.h
index 9b97a6a..7d4f342 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -20,6 +20,8 @@
 #ifndef _SCM_VM_H_
 #define _SCM_VM_H_
 
+#include <setjmp.h>
+
 #include <libguile/gc.h>
 #include <libguile/programs.h>
 
@@ -120,6 +122,8 @@ SCM_INTERNAL SCM scm_i_vm_capture_stack (union 
scm_vm_stack_element *stack_top,
                                          uint32_t *ra,
                                          scm_t_dynstack *dynstack,
                                          uint32_t flags);
+SCM_INTERNAL void scm_i_vm_abort (struct scm_vm *vp, SCM tag, size_t n, SCM 
*argv,
+                                  jmp_buf *registers) SCM_NORETURN;
 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);