[Guile-commits] 02/13: Rework program->ip mapping in VM to always call intrinsic

[Andy Wingo]

wingo pushed a commit to branch lightning
in repository guile.

commit 926b72f5acb058cadd95bd60c4a89efb2977fe6b
Author: Andy Wingo <address@hidden>
Date:   Wed Aug 8 15:22:28 2018 +0200

    Rework program->ip mapping in VM to always call intrinsic
    
    * libguile/intrinsics.h:
    * libguile/vm.c (get_callee_vcode): Rename from apply_non_program, and
      instead return the IP for the callee of a frame.
      (scm_call_n, scm_bootstrap_vm): Adapt to get_callee_vcode change.
    * libguile/vm-engine.c (call, tail-call, call/cc): Use
      get_callee_vcode unconditionally.  JIT will do this to avoid so much
      code generation for calls.
---
 libguile/intrinsics.h |  3 ++-
 libguile/vm-engine.c  | 33 ++++++++-------------------------
 libguile/vm.c         | 25 +++++++++----------------
 3 files changed, 19 insertions(+), 42 deletions(-)

diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h
index 3bd264f..136c29f 100644
--- a/libguile/intrinsics.h
+++ b/libguile/intrinsics.h
@@ -66,6 +66,7 @@ typedef void (*scm_t_thread_u8_scm_sp_vra_intrinsic) 
(scm_thread*,
                                                       const union 
scm_vm_stack_element*,
                                                       uint32_t*);
 typedef void (*scm_t_thread_mra_intrinsic) (scm_thread*, uint8_t*);
+typedef uint32_t* (*scm_t_vra_from_thread_intrinsic) (scm_thread*);
 
 #define SCM_FOR_ALL_VM_INTRINSICS(M) \
   M(scm_from_scm_scm, add, "add", ADD) \
@@ -128,7 +129,7 @@ typedef void (*scm_t_thread_mra_intrinsic) (scm_thread*, 
uint8_t*);
   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) \
+  M(vra_from_thread, get_callee_vcode, "get-callee-vcode", GET_CALLEE_VCODE) \
   M(scm_from_thread_u64, allocate_words, "allocate-words", ALLOCATE_WORDS) \
   M(scm_from_thread, current_module, "current-module", CURRENT_MODULE) \
   M(thread_u8_scm_sp_vra, push_prompt, "push-prompt", PUSH_PROMPT) \
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 65342b6..eaaa285 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -379,16 +379,10 @@ VM_NAME (scm_thread *thread)
       SCM_FRAME_SET_MACHINE_RETURN_ADDRESS (new_fp, 0);
       VP->fp = new_fp;
 
+      SYNC_IP ();
       RESET_FRAME (nlocals);
-
-      if (SCM_LIKELY (SCM_PROGRAM_P (FP_REF (0))))
-        ip = SCM_PROGRAM_CODE (FP_REF (0));
-      else
-        {
-          SYNC_IP ();
-          CALL_INTRINSIC (apply_non_program, (thread));
-          CACHE_REGISTER ();
-        }
+      ip = CALL_INTRINSIC (get_callee_vcode, (thread));
+      CACHE_SP ();
 
       NEXT (0);
     }
@@ -435,15 +429,9 @@ VM_NAME (scm_thread *thread)
    */
   VM_DEFINE_OP (3, tail_call, "tail-call", OP1 (X32))
     {
-      if (SCM_LIKELY (SCM_PROGRAM_P (FP_REF (0))))
-        ip = SCM_PROGRAM_CODE (FP_REF (0));
-      else
-        {
-          SYNC_IP ();
-          CALL_INTRINSIC (apply_non_program, (thread));
-          CACHE_REGISTER ();
-        }
-
+      SYNC_IP ();
+      ip = CALL_INTRINSIC (get_callee_vcode, (thread));
+      CACHE_SP ();
       NEXT (0);
     }
 
@@ -756,13 +744,8 @@ VM_NAME (scm_thread *thread)
       SP_SET (1, SP_REF (0));
       SP_SET (0, cont);
 
-      if (SCM_LIKELY (SCM_PROGRAM_P (SP_REF (1))))
-        ip = SCM_PROGRAM_CODE (SP_REF (1));
-      else
-        {
-          CALL_INTRINSIC (apply_non_program, (thread));
-          CACHE_REGISTER ();
-        }
+      ip = CALL_INTRINSIC (get_callee_vcode, (thread));
+      CACHE_SP ();
 
       NEXT (0);
     }
diff --git a/libguile/vm.c b/libguile/vm.c
index cb42783..ff01f62 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -1296,23 +1296,23 @@ abort_to_prompt (scm_thread *thread)
     longjmp (*registers, 1);
 }
 
-static void
-apply_non_program (scm_thread *thread)
+static uint32_t *
+get_callee_vcode (scm_thread *thread)
 {
   struct scm_vm *vp = &thread->vm;
 
   SCM proc = SCM_FRAME_LOCAL (vp->fp, 0);
 
+  if (SCM_LIKELY (SCM_PROGRAM_P (proc)))
+    return SCM_PROGRAM_CODE (proc);
+
   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;
-        }
+        return SCM_PROGRAM_CODE (proc);
     }
 
   if (SCM_HAS_TYP7 (proc, scm_tc7_smob) && SCM_SMOB_APPLICABLE_P (proc))
@@ -1329,8 +1329,7 @@ apply_non_program (scm_thread *thread)
 
       proc = SCM_SMOB_DESCRIPTOR (proc).apply_trampoline;
       SCM_FRAME_LOCAL (vp->fp, 0) = proc;
-      vp->ip = SCM_PROGRAM_CODE (proc);
-      return;
+      return SCM_PROGRAM_CODE (proc);
     }
 
   scm_error (scm_arg_type_key, NULL, "Wrong type to apply: ~S",
@@ -1401,13 +1400,7 @@ scm_call_n (SCM proc, SCM *argv, size_t nargs)
           vm_dispatch_abort_hook (thread);
       }
     else
-      {
-        if (SCM_LIKELY (SCM_PROGRAM_P (proc)))
-          vp->ip = SCM_PROGRAM_CODE (proc);
-        else
-          /* FIXME: Make this return an IP.  */
-          apply_non_program (thread);
-      }
+      vp->ip = get_callee_vcode (thread);
 
     thread->vm.registers = &registers;
     ret = vm_engines[vp->engine](thread);
@@ -1687,7 +1680,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;
+  scm_vm_intrinsics.get_callee_vcode = get_callee_vcode;
 
   sym_keyword_argument_error = scm_from_latin1_symbol 
("keyword-argument-error");
   sym_regular = scm_from_latin1_symbol ("regular");