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

@@ -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) \

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;
 
-      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));
+      RESET_FRAME (nlocals);
-          CACHE_REGISTER ();
+      ip = CALL_INTRINSIC (get_callee_vcode, (thread));
-        }
+      CACHE_SP ();
 
       NEXT (0);
     }
@@ -434,16 +428,10 @@ VM_NAME (scm_thread *thread)
    * have already been shuffled into position.
    */
   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));
+      ip = CALL_INTRINSIC (get_callee_vcode, (thread));
-          CACHE_REGISTER ();
+      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 = CALL_INTRINSIC (get_callee_vcode, (thread));
-        ip = SCM_PROGRAM_CODE (SP_REF (1));
+      CACHE_SP ();
-      else
-        {
-          CALL_INTRINSIC (apply_non_program, (thread));
-          CACHE_REGISTER ();
-        }
 
       NEXT (0);
     }

libguile/vm.c

@@ -1296,23 +1296,23 @@ abort_to_prompt (scm_thread *thread)
     longjmp (*registers, 1);
 }
 
-static void
+static uint32_t *
-apply_non_program (scm_thread *thread)
+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))
-        {
+        return SCM_PROGRAM_CODE (proc);
-          vp->ip = SCM_PROGRAM_CODE (proc);
-          return;
-        }
     }
 
   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 SCM_PROGRAM_CODE (proc);
-      return;
     }
 
   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
-      {
+      vp->ip = get_callee_vcode (thread);
-        if (SCM_LIKELY (SCM_PROGRAM_P (proc)))
-          vp->ip = SCM_PROGRAM_CODE (proc);
-        else
-          /* FIXME: Make this return an IP.  */
-          apply_non_program (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");