[Guile-commits] 04/05: Apply-non-program is an intrinsic

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 1735cc1fec419d6aee5787c79f5ac5727bfada5d
Author: Andy Wingo <address@hidden>
Date:   Wed Jun 27 13:38:30 2018 +0200

    Apply-non-program is an intrinsic
    
    * libguile/intrinsics.h (SCM_FOR_ALL_VM_INTRINSICS): Add
      apply-non-program intrinsic.
    * libguile/vm-engine.c (apply-non-program): Replace impl with call to
      intrinsic.
    * libguile/vm.c (vm_error_wrong_type_apply): Inline into
      apply_non_program intrinsic.
      (apply_non_program): New intrinsic.
      (scm_bootstrap_vm): Wire it up.
---
 libguile/intrinsics.h |  1 +
 libguile/vm-engine.c  | 33 +++------------------------------
 libguile/vm.c         | 50 ++++++++++++++++++++++++++++++++++++++++++--------
 3 files changed, 46 insertions(+), 38 deletions(-)

diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h
index 6526abc..ac59661 100644
--- a/libguile/intrinsics.h
+++ b/libguile/intrinsics.h
@@ -124,6 +124,7 @@ typedef void (*scm_t_u32_noreturn_intrinsic) (uint32_t) 
SCM_NORETURN;
   M(noreturn, error_no_values, "no-values", ERROR_NO_VALUES) \
   M(noreturn, error_not_enough_values, "not-enough-values", 
ERROR_NOT_ENOUGH_VALUES) \
   M(u32_noreturn, error_wrong_number_of_values, "wrong-number-of-values", 
ERROR_WRONG_NUMBER_OF_VALUES) \
+  M(thread, apply_non_program, "apply-non-program", APPLY_NON_PROGRAM) \
   /* 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 0cf1a0c..0236329 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -2033,36 +2033,9 @@ VM_NAME (scm_thread *thread, jmp_buf *registers, int 
resume)
    */
   VM_DEFINE_OP (142, apply_non_program, "apply-non-program", OP1 (X32))
     {
-      SCM proc = FP_REF (0);
-
-      while (!SCM_PROGRAM_P (proc))
-        {
-          if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
-            {
-              proc = SCM_STRUCT_PROCEDURE (proc);
-              FP_SET (0, proc);
-              continue;
-            }
-          if (SCM_HAS_TYP7 (proc, scm_tc7_smob) && SCM_SMOB_APPLICABLE_P 
(proc))
-            {
-              uint32_t n = FRAME_LOCALS_COUNT();
-
-              /* Shuffle args up.  (FIXME: no real need to shuffle; just set
-                 IP and go. ) */
-              ALLOC_FRAME (n + 1);
-              while (n--)
-                FP_SET (n + 1, FP_REF (n));
-
-              proc = SCM_SMOB_DESCRIPTOR (proc).apply_trampoline;
-              FP_SET (0, proc);
-              continue;
-            }
-
-          SYNC_IP();
-          vm_error_wrong_type_apply (proc);
-        }
-
-      ip = SCM_PROGRAM_CODE (proc);
+      SYNC_IP ();
+      scm_vm_intrinsics.apply_non_program (thread);
+      CACHE_REGISTER ();
       NEXT (0);
     }
 
diff --git a/libguile/vm.c b/libguile/vm.c
index 9e12274..1b224d4 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -308,7 +308,6 @@ static void vm_dispatch_abort_hook (struct scm_vm *vp)
 
 
 static void vm_error_bad_instruction (uint32_t inst) SCM_NORETURN SCM_NOINLINE;
-static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE;
 
 static void
 vm_error_bad_instruction (uint32_t inst)
@@ -317,13 +316,6 @@ vm_error_bad_instruction (uint32_t inst)
   abort ();
 }
 
-static void
-vm_error_wrong_type_apply (SCM proc)
-{
-  scm_error (scm_arg_type_key, NULL, "Wrong type to apply: ~S",
-             scm_list_1 (proc), scm_list_1 (proc));
-}
-
 
 
 
@@ -1332,6 +1324,47 @@ abort_to_prompt (scm_thread *thread, jmp_buf 
*current_registers)
     longjmp (*registers, 1);
 }
 
+static void
+apply_non_program (scm_thread *thread)
+{
+  struct scm_vm *vp = &thread->vm;
+
+  SCM proc = SCM_FRAME_LOCAL (vp->fp, 0);
+
+  while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
+    {
+      proc = SCM_STRUCT_PROCEDURE (proc);
+      SCM_FRAME_LOCAL (vp->fp, 0) = proc;
+
+      if (SCM_PROGRAM_P (proc))
+        {
+          vp->ip = SCM_PROGRAM_CODE (proc);
+          return;
+        }
+    }
+
+  if (SCM_HAS_TYP7 (proc, scm_tc7_smob) && SCM_SMOB_APPLICABLE_P (proc))
+    {
+      uint32_t n = frame_locals_count (thread);
+
+      alloc_frame (thread, n + 1);
+
+      /* Although we could make VM modifications to avoid this shuffle,
+         it's easier to piggy-back on the subr arg parsing machinery.
+         Hopefully applicable smobs will go away in the mid-term.  */
+      while (n--)
+        SCM_FRAME_LOCAL (vp->fp, n + 1) = SCM_FRAME_LOCAL (vp->fp, n);
+
+      proc = SCM_SMOB_DESCRIPTOR (proc).apply_trampoline;
+      SCM_FRAME_LOCAL (vp->fp, 0) = proc;
+      vp->ip = SCM_PROGRAM_CODE (proc);
+      return;
+    }
+
+  scm_error (scm_arg_type_key, NULL, "Wrong type to apply: ~S",
+             scm_list_1 (proc), scm_list_1 (proc));
+}
+
 SCM
 scm_call_n (SCM proc, SCM *argv, size_t nargs)
 {
@@ -1680,6 +1713,7 @@ scm_bootstrap_vm (void)
   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;
+  scm_vm_intrinsics.apply_non_program = apply_non_program;
 
   sym_keyword_argument_error = scm_from_latin1_symbol 
("keyword-argument-error");
   sym_regular = scm_from_latin1_symbol ("regular");