first step to make the vm stop calling the interpreter

* libguile/eval.h:
* libguile/eval.c (scm_closure_apply): New function, applies a closure.
  Won't be necessary in the future, but for now here it is, with
  internal linkage.

* libguile/gsubr.h:
* libguile/gsubr.c (scm_i_gsubr_apply_array): New function, applies a
  gsubr to an array of values, potentially extending that array for
  optional arguments and rest arguments and such.

* libguile/vm.c (apply_foreign): New function, applies a foreign
  function to arguments on the stack, in place.

* libguile/vm-i-system.c (call): Add a case for procedures-with-setters
  (will go away when they are applicable structs). Instead of calling
  the evaluator for foreign functions, call apply_foreign.

diff --git a/libguile/eval.c b/libguile/eval.c
index 4b8cc0a..664d662 100644 (file)
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -539,6 +539,41 @@ apply (SCM proc, SCM args)
     }
 }
 
+SCM
+scm_closure_apply (SCM proc, SCM args)
+{
+  unsigned int nargs;
+  int nreq;
+  SCM env;
+
+  /* Args contains a list of all args. */
+  {
+    int ilen = scm_ilength (args);
+    if (ilen < 0)
+      scm_wrong_num_args (proc);
+    nargs = ilen;
+  }
+
+  nreq = SCM_CLOSURE_NUM_REQUIRED_ARGS (proc);
+  env = SCM_ENV (proc);
+  if (SCM_CLOSURE_HAS_REST_ARGS (proc))
+    {
+      if (SCM_UNLIKELY (scm_ilength (args) < nreq))
+        scm_wrong_num_args (proc);
+      for (; nreq; nreq--, args = CDR (args))
+        env = scm_cons (CAR (args), env);
+      env = scm_cons (args, env);
+    }
+  else
+    {
+      for (; scm_is_pair (args); args = CDR (args), nreq--)
+        env = scm_cons (CAR (args), env);
+      if (SCM_UNLIKELY (nreq != 0))
+        scm_wrong_num_args (proc);
+    }
+  return eval (SCM_CLOSURE_BODY (proc), env);
+}
+
 
 scm_t_option scm_eval_opts[] = {
   { SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." },

diff --git a/libguile/eval.h b/libguile/eval.h
index f10110f..62b84c1 100644 (file)
--- a/libguile/eval.h
+++ b/libguile/eval.h
@@ -76,6 +76,7 @@ SCM_API SCM scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args);
 SCM_INTERNAL SCM scm_i_call_closure_0 (SCM proc);
 SCM_API SCM scm_nconc2last (SCM lst);
 SCM_API SCM scm_apply (SCM proc, SCM arg1, SCM args);
+SCM_INTERNAL SCM scm_closure_apply (SCM proc, SCM args);
 #define scm_dapply(proc,arg1,args) scm_apply (proc, arg1, args)
 SCM_API SCM scm_map (SCM proc, SCM arg1, SCM args);
 SCM_API SCM scm_for_each (SCM proc, SCM arg1, SCM args);

diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index 3b73155..6123a0b 100644 (file)
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -317,6 +317,45 @@ scm_i_gsubr_apply_list (SCM self, SCM args)
 }
 #undef FUNC_NAME
 
+/* Apply SELF, a gsubr, to the arguments in ARGS.  Missing optional
+   arguments are added, and rest arguments are consed into a list.  */
+SCM
+scm_i_gsubr_apply_array (SCM self, SCM *args, int nargs, int headroom)
+#define FUNC_NAME "scm_i_gsubr_apply"
+{
+  unsigned int typ = SCM_GSUBR_TYPE (self);
+  long i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ);
+
+  if (SCM_UNLIKELY (nargs < SCM_GSUBR_REQ (typ)))
+    scm_wrong_num_args (SCM_SUBR_NAME (self));
+
+  if (SCM_UNLIKELY (headroom < n - nargs))
+    {
+      /* fallback on apply-list */
+      SCM arglist = SCM_EOL;
+      while (nargs--)
+        arglist = scm_cons (args[nargs], arglist);
+      return scm_i_gsubr_apply_list (self, arglist);
+    }
+
+  for (i = nargs; i < SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ); i++)
+    args[i] = SCM_UNDEFINED;
+
+  if (SCM_GSUBR_REST(typ))
+    {
+      SCM rest = SCM_EOL;
+      /* fallback on apply-list */
+      while (nargs-- >= n)
+        rest = scm_cons (args[nargs], rest);
+      args[n - 1] = rest;
+    }
+  else if (nargs > n)
+    scm_wrong_num_args (SCM_SUBR_NAME (self));
+
+  return gsubr_apply_raw (self, n, args);
+}
+#undef FUNC_NAME
+
 
 #ifdef GSUBR_TEST
 /* A silly example, taking 2 required args, 1 optional, and

diff --git a/libguile/gsubr.h b/libguile/gsubr.h
index 298181b..e75658d 100644 (file)
--- a/libguile/gsubr.h
+++ b/libguile/gsubr.h
@@ -51,6 +51,8 @@ SCM_API SCM scm_c_define_gsubr_with_generic (const char *name,
 
 SCM_INTERNAL SCM scm_i_gsubr_apply (SCM proc, SCM arg, ...);
 SCM_INTERNAL SCM scm_i_gsubr_apply_list (SCM proc, SCM args);
+SCM_INTERNAL SCM scm_i_gsubr_apply_array (SCM proc, SCM *args, int nargs,
+                                          int headroom);
 SCM_INTERNAL void scm_init_gsubr (void);
 
 #endif  /* SCM_GSUBR_H */

diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index a8fa2d3..5cfeab0 100644 (file)
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -766,32 +766,38 @@ VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
       sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
       goto vm_call;
     }
+  else if (SCM_PROCEDURE_WITH_SETTER_P (x))
+    {
+      sp[-nargs] = SCM_PROCEDURE (x);
+      goto vm_call;
+    }
   /*
    * Other interpreted or compiled call
    */
   if (!scm_is_false (scm_procedure_p (x)))
     {
-      SCM args;
+      SCM ret;
       /* At this point, the stack contains the frame, the procedure and each one
         of its arguments. */
-      POP_LIST (nargs);
-      POP (args);
-      DROP (); /* drop the procedure */
-      DROP_FRAME ();
-      
       SYNC_REGISTER ();
-      PUSH (scm_apply (x, args, SCM_EOL));
+      ret = apply_foreign (sp[-nargs],
+                           sp - nargs + 1,
+                           nargs,
+                           vp->stack_limit - sp + 1);
       NULLSTACK_FOR_NONLOCAL_EXIT ();
-      if (SCM_UNLIKELY (SCM_VALUESP (*sp)))
+      DROPN (nargs + 1); /* drop args and procedure */
+      DROP_FRAME ();
+      
+      if (SCM_UNLIKELY (SCM_VALUESP (ret)))
         {
           /* truncate values */
-          SCM values;
-          POP (values);
-          values = scm_struct_ref (values, SCM_INUM0);
-          if (scm_is_null (values))
+          ret = scm_struct_ref (ret, SCM_INUM0);
+          if (scm_is_null (ret))
             goto vm_error_not_enough_values;
-          PUSH (SCM_CAR (values));
+          PUSH (SCM_CAR (ret));
         }
+      else
+        PUSH (ret);
       NEXT;
     }
 

diff --git a/libguile/vm.c b/libguile/vm.c
index 055bbee..f9e4abe 100644 (file)
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -262,6 +262,134 @@ resolve_variable (SCM what, SCM program_module)
     }
 }
   
+static SCM
+apply_foreign (SCM proc, SCM *args, int nargs, int headroom)
+{
+  SCM arg1, arg2, arg3;
+
+  SCM_ASRTGO (SCM_NIMP (proc), badproc);
+
+  /* Parse args. */
+  switch (nargs)
+    {
+    case 0:
+      arg1 = SCM_UNDEFINED; arg2 = SCM_UNDEFINED; arg3 = SCM_UNDEFINED;
+      break;
+    case 1:
+      arg1 = args[0]; arg2 = SCM_UNDEFINED; arg3 = SCM_UNDEFINED;
+      break;
+    case 2:
+      arg1 = args[0]; arg2 = args[1]; arg3 = SCM_UNDEFINED;
+      break;
+    default:
+      arg1 = args[0]; arg2 = args[1]; arg3 = args[2];
+      break;
+    }
+
+  switch (SCM_TYP7 (proc))
+    {
+    case scm_tcs_closures:
+      /* FIXME: pre-boot closures should be smobs */
+      {
+        SCM arglist = SCM_EOL;
+        while (nargs--)
+          arglist = scm_cons (args[nargs], arglist);
+        return scm_closure_apply (proc, arglist);
+      }
+    case scm_tc7_subr_2o:
+      if (nargs > 2 || nargs < 1) scm_wrong_num_args (proc);
+      return SCM_SUBRF (proc) (arg1, arg2);
+    case scm_tc7_subr_2:
+      if (nargs != 2) scm_wrong_num_args (proc);
+      return SCM_SUBRF (proc) (arg1, arg2);
+    case scm_tc7_subr_0:
+      if (nargs != 0) scm_wrong_num_args (proc);
+      return SCM_SUBRF (proc) ();
+    case scm_tc7_subr_1:
+      if (nargs != 1) scm_wrong_num_args (proc);
+      return SCM_SUBRF (proc) (arg1);
+    case scm_tc7_subr_1o:
+      if (nargs > 1) scm_wrong_num_args (proc);
+      return SCM_SUBRF (proc) (arg1);
+    case scm_tc7_dsubr:
+      if (nargs != 1) scm_wrong_num_args (proc);
+      if (SCM_I_INUMP (arg1))
+        return scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1)));
+      else if (SCM_REALP (arg1))
+        return scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)));
+      else if (SCM_BIGP (arg1))
+        return scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)));
+      else if (SCM_FRACTIONP (arg1))
+        return scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)));
+      SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
+                          SCM_ARG1, scm_i_symbol_chars (SCM_SUBR_NAME (proc)));
+    case scm_tc7_cxr:
+      if (nargs != 1) scm_wrong_num_args (proc);
+      return scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc));
+    case scm_tc7_subr_3:
+      if (nargs != 3) scm_wrong_num_args (proc);
+      return SCM_SUBRF (proc) (arg1, arg2, arg3);
+    case scm_tc7_lsubr:
+      {
+        SCM arglist = SCM_EOL;
+        while (nargs--)
+          arglist = scm_cons (args[nargs], arglist);
+        return SCM_SUBRF (proc) (arglist);
+      }
+    case scm_tc7_lsubr_2:
+      if (nargs < 2) scm_wrong_num_args (proc);
+      {
+        SCM arglist = SCM_EOL;
+        while (nargs-- > 2)
+          arglist = scm_cons (args[nargs], arglist);
+        return SCM_SUBRF (proc) (arg1, arg2, arglist);
+      }
+    case scm_tc7_asubr:
+      if (nargs < 2)
+        return SCM_SUBRF (proc) (arg1, SCM_UNDEFINED);
+      {
+        int idx = 1;
+        while (nargs-- > 1)
+          arg1 = SCM_SUBRF (proc) (arg1, args[idx++]);
+        return arg1;
+      }
+    case scm_tc7_rpsubr:
+      {
+        int idx = 0;
+        while (nargs-- > 1)
+          { idx++;
+            if (scm_is_false (SCM_SUBRF (proc) (args[idx-1], args[idx])))
+              return SCM_BOOL_F;
+          }
+        return SCM_BOOL_T;
+      }
+    case scm_tc7_smob:
+      if (!SCM_SMOB_APPLICABLE_P (proc))
+        goto badproc;
+      switch (nargs)
+        {
+        case 0:
+          return SCM_SMOB_APPLY_0 (proc);
+        case 1:
+          return SCM_SMOB_APPLY_1 (proc, arg1);
+        case 2:
+          return SCM_SMOB_APPLY_2 (proc, arg1, arg2);
+        default:
+          {
+            SCM arglist = SCM_EOL;
+            while (nargs-- > 2)
+              arglist = scm_cons (args[nargs], arglist);
+            return SCM_SMOB_APPLY_3 (proc, arg1, arg2, arglist);
+          }
+        }
+    case scm_tc7_gsubr:
+      return scm_i_gsubr_apply_array (proc, args, nargs, headroom);
+    default:
+    badproc:
+      scm_wrong_type_arg ("apply", SCM_ARG1, proc);
+    }
+}
+
 
 #define VM_DEFAULT_STACK_SIZE  (64 * 1024)