Add rest-arg-length intrinsic.

* libguile/intrinsics.h:
* libguile/vm.c (rest_arg_length): New intrinsic.
  (vm_error_apply_to_non_list): Remove now-unused error proc.
* libguile/vm-engine.c (tail-apply): Use new intrinsic.

libguile/intrinsics.h

@@ -56,6 +56,7 @@ typedef SCM (*scm_t_scm_from_scm_scm_scmp_sp_intrinsic) (SCM, SCM, SCM*,
 typedef void (*scm_t_thread_scm_noreturn_intrinsic) (scm_thread*, SCM) SCM_NORETURN;
 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);
 
 #define SCM_FOR_ALL_VM_INTRINSICS(M) \
   M(scm_from_scm_scm, add, "add", ADD) \
@@ -109,6 +110,7 @@ typedef void (*scm_t_thread_regs_scm_intrinsic) (scm_thread*, jmp_buf*, SCM);
   M(thread_scm_noreturn, reinstate_continuation_x, "reinstate-continuation!", REINSTATE_CONTINUATION_X) \
   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) \
   /* Add new intrinsics here; also update scm_bootstrap_intrinsics.  */
 
 enum scm_vm_intrinsic

libguile/vm-engine.c

@@ -703,7 +703,7 @@ VM_NAME (scm_thread *thread, jmp_buf *registers, int resume)
 
   /* tail-apply _:24
    *
-   * Tail-apply the procedure in local slot 0 to the rest of the
+   * Tail-apply the procedure in local slot 1 to the rest of the
    * arguments.  This instruction is part of the implementation of
    * `apply', and is not generated by the compiler.
    */
@@ -717,9 +717,9 @@ VM_NAME (scm_thread *thread, jmp_buf *registers, int resume)
       VM_ASSERT (nlocals >= 3, abort ());
       list_idx = nlocals - 1;
       list = FP_REF (list_idx);
-      list_len = scm_ilength (list);
 
-      VM_ASSERT (list_len >= 0, vm_error_apply_to_non_list (list));
+      SYNC_IP ();
+      list_len = scm_vm_intrinsics.rest_arg_length (list);
 
       nlocals = nlocals - 2 + list_len;
       ALLOC_FRAME (nlocals);

libguile/vm.c

@@ -334,7 +334,6 @@ static void vm_throw_with_value_and_data (SCM val, SCM key_subr_and_message) SCM
 
 static void vm_error (const char *msg, SCM arg) SCM_NORETURN;
 static void vm_error_bad_instruction (uint32_t inst) SCM_NORETURN SCM_NOINLINE;
-static void vm_error_apply_to_non_list (SCM x) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_wrong_num_args (SCM proc) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE;
@@ -390,13 +389,6 @@ vm_error_bad_instruction (uint32_t inst)
   vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst));
 }
 
-static void
-vm_error_apply_to_non_list (SCM x)
-{
-  scm_error (scm_arg_type_key, "apply", "Apply to non-list: ~S",
-             scm_list_1 (x), scm_list_1 (x));
-}
-
 static void
 vm_error_wrong_num_args (SCM proc)
 {
@@ -1310,6 +1302,18 @@ compose_continuation (scm_thread *thread, jmp_buf *registers, SCM cont)
   }
 }
 
+static int
+rest_arg_length (SCM x)
+{
+  int len = scm_ilength (x);
+
+  if (SCM_UNLIKELY (len < 0))
+    scm_error (scm_arg_type_key, "apply", "Apply to non-list: ~S",
+               scm_list_1 (x), scm_list_1 (x));
+
+  return len;
+}
+
 SCM
 scm_call_n (SCM proc, SCM *argv, size_t nargs)
 {
@@ -1656,6 +1660,7 @@ scm_bootstrap_vm (void)
   scm_vm_intrinsics.reinstate_continuation_x = reinstate_continuation_x;
   scm_vm_intrinsics.capture_continuation = capture_continuation;
   scm_vm_intrinsics.compose_continuation = compose_continuation;
+  scm_vm_intrinsics.rest_arg_length = rest_arg_length;
 
   sym_vm_run = scm_from_latin1_symbol ("vm-run");
   sym_vm_error = scm_from_latin1_symbol ("vm-error");