[Guile-commits] 04/13: Intrinsic for "prompt"

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 294e627c6b76f3b496c9f205fce2e128f4731d1c
Author: Andy Wingo <address@hidden>
Date:   Wed Jun 27 15:29:49 2018 +0200

    Intrinsic for "prompt"
    
    * libguile/intrinsics.h (SCM_FOR_ALL_VM_INTRINSICS):
    * libguile/intrinsics.c (push_prompt, scm_bootstrap_intrinsics): New
      intrinsic.
    * libguile/vm-engine.c (prompt): Use push-prompt intrinsic.
---
 libguile/intrinsics.c | 14 ++++++++++++++
 libguile/intrinsics.h |  5 +++++
 libguile/vm-engine.c  | 12 ++++--------
 3 files changed, 23 insertions(+), 8 deletions(-)

diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c
index 59192d1..42b6610 100644
--- a/libguile/intrinsics.c
+++ b/libguile/intrinsics.c
@@ -26,6 +26,7 @@
 #include "cache-internal.h"
 #include "extensions.h"
 #include "fluids.h"
+#include "frames.h"
 #include "gc-inline.h"
 #include "goops.h"
 #include "gsubr.h"
@@ -346,6 +347,18 @@ current_module (scm_thread *thread)
   return scm_i_current_module (thread);
 }
 
+static void
+push_prompt (scm_thread *thread, jmp_buf *registers, uint8_t escape_only_p,
+             SCM tag, const union scm_vm_stack_element *sp, void *ra)
+{
+  struct scm_vm *vp = &thread->vm;
+  scm_t_dynstack_prompt_flags flags;
+
+  flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0;
+  scm_dynstack_push_prompt (&thread->dynstack, flags, tag,
+                            vp->stack_top - vp->fp, vp->stack_top - sp,
+                            ra, registers);
+}
 
 void
 scm_bootstrap_intrinsics (void)
@@ -401,6 +414,7 @@ scm_bootstrap_intrinsics (void)
   scm_vm_intrinsics.error_wrong_number_of_values = 
error_wrong_number_of_values;
   scm_vm_intrinsics.allocate_words = allocate_words;
   scm_vm_intrinsics.current_module = current_module;
+  scm_vm_intrinsics.push_prompt = push_prompt;
 
   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
                             "scm_init_intrinsics",
diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h
index 7a122d9..c44f832 100644
--- a/libguile/intrinsics.h
+++ b/libguile/intrinsics.h
@@ -64,6 +64,10 @@ typedef void (*scm_t_scm_noreturn_intrinsic) (SCM) 
SCM_NORETURN;
 typedef void (*scm_t_u32_noreturn_intrinsic) (uint32_t) SCM_NORETURN;
 typedef SCM (*scm_t_scm_from_thread_u64_intrinsic) (scm_thread*, uint64_t);
 typedef SCM (*scm_t_scm_from_thread_intrinsic) (scm_thread*);
+typedef void (*scm_t_thread_regs_u8_scm_sp_ra_intrinsic) (scm_thread*, 
jmp_buf*,
+                                                          uint8_t, SCM,
+                                                          const union 
scm_vm_stack_element*,
+                                                          void*);
 
 #define SCM_FOR_ALL_VM_INTRINSICS(M) \
   M(scm_from_scm_scm, add, "add", ADD) \
@@ -129,6 +133,7 @@ typedef SCM (*scm_t_scm_from_thread_intrinsic) 
(scm_thread*);
   M(thread, apply_non_program, "apply-non-program", APPLY_NON_PROGRAM) \
   M(scm_from_thread_u64, allocate_words, "allocate-words", ALLOCATE_WORDS) \
   M(scm_from_thread, current_module, "current-module", CURRENT_MODULE) \
+  M(thread_regs_u8_scm_sp_ra, push_prompt, "push-prompt", PUSH_PROMPT) \
   /* Add new intrinsics here; also update scm_bootstrap_intrinsics.  */
 
 enum scm_vm_intrinsic
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 357aceb..7e4bd89 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -1671,7 +1671,6 @@ VM_NAME (scm_thread *thread, jmp_buf *registers, int 
resume)
       uint32_t tag, proc_slot;
       int32_t offset;
       uint8_t escape_only_p;
-      scm_t_dynstack_prompt_flags flags;
 
       UNPACK_24 (op, tag);
       escape_only_p = ip[1] & 0x1;
@@ -1680,14 +1679,11 @@ VM_NAME (scm_thread *thread, jmp_buf *registers, int 
resume)
       offset >>= 8; /* Sign extension */
   
       /* Push the prompt onto the dynamic stack. */
-      flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0;
       SYNC_IP ();
-      scm_dynstack_push_prompt (&thread->dynstack, flags,
-                                SP_REF (tag),
-                                VP->stack_top - VP->fp,
-                                VP->stack_top - FP_SLOT (proc_slot),
-                                ip + offset,
-                                registers);
+      scm_vm_intrinsics.push_prompt (thread, registers, escape_only_p,
+                                     SP_REF (tag), FP_SLOT (proc_slot),
+                                     ip + offset);
+
       NEXT (3);
     }