[Guile-commits] 11/26: Move VM keyword argument parsing to happen via an intrinsic

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 8e5755e7719b2bab69c509e4bf0ab2e8bcdc8a10
Author: Andy Wingo <address@hidden>
Date:   Sun Jun 24 11:49:42 2018 +0200

    Move VM keyword argument parsing to happen via an intrinsic
    
    * libguile/intrinsics.h (SCM_FOR_ALL_VM_INTRINSICS): Add new intrinsics
      for binding keyword arguments.
    * libguile/vm-engine.c (bind_kwargs): Call intrinsics.
    * libguile/vm.c (vm_error_kwargs_missing_value)
      (vm_error_kwargs_invalid_keyword)
      (vm_error_kwargs_unrecognized_keyword): Remove unused error cases.
      (frame_locals_count, alloc_frame): New helper.
      (compute_kwargs_npositional, bind_kwargs, cons_rest): New intrinsics.
      (scm_bootstrap_vm): Define intrinsics.
---
 libguile/intrinsics.h |   8 +++
 libguile/vm-engine.c  |  71 ++++-------------------
 libguile/vm.c         | 154 +++++++++++++++++++++++++++++++++++++++++---------
 3 files changed, 146 insertions(+), 87 deletions(-)

diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h
index 46a7fdd..85f4a2e 100644
--- a/libguile/intrinsics.h
+++ b/libguile/intrinsics.h
@@ -43,6 +43,11 @@ typedef SCM (*scm_t_scm_from_scm_u64_intrinsic) (SCM, 
uint64_t);
 typedef int (*scm_t_bool_from_scm_scm_intrinsic) (SCM, SCM);
 typedef enum scm_compare (*scm_t_compare_from_scm_scm_intrinsic) (SCM, SCM);
 typedef void (*scm_t_thread_sp_intrinsic) (scm_i_thread*, union 
scm_vm_stack_element*);
+typedef SCM (*scm_t_scm_from_thread_u32_intrinsic) (scm_i_thread*, uint32_t);
+typedef uint32_t (*scm_t_u32_from_thread_u32_u32_intrinsic) (scm_i_thread*, 
uint32_t, uint32_t);
+typedef void (*scm_t_thread_u32_u32_scm_u8_u8_intrinsic) (scm_i_thread*, 
uint32_t,
+                                                          uint32_t, SCM, 
uint8_t,
+                                                          uint8_t);
 
 #define SCM_FOR_ALL_VM_INTRINSICS(M) \
   M(scm_from_scm_scm, add, "add", ADD) \
@@ -88,6 +93,9 @@ typedef void (*scm_t_thread_sp_intrinsic) (scm_i_thread*, 
union scm_vm_stack_ele
   M(scm_from_scm_scm, lookup, "lookup", LOOKUP) \
   M(scm_from_scm_scm, define_x, "define!", DEFINE_X) \
   M(thread_sp, expand_stack, "expand-stack", EXPAND_STACK) \
+  M(scm_from_thread_u32, cons_rest, "cons-rest", CONS_REST) \
+  M(u32_from_thread_u32_u32, compute_kwargs_npositional, 
"compute-kwargs-npositional", COMPUTE_KWARGS_NPOSITIONAL) \
+  M(thread_u32_u32_scm_u8_u8, bind_kwargs, "bind-kwargs", BIND_KWARGS)  \
   /* 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 4874c0f..6eb0474 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -1087,11 +1087,12 @@ VM_NAME (scm_i_thread *thread, jmp_buf *registers, int 
resume)
    */
   VM_DEFINE_OP (31, bind_kwargs, "bind-kwargs", OP4 (X8_C24, C8_C24, X8_C24, 
N32))
     {
-      uint32_t nreq, nreq_and_opt, ntotal, npositional, nkw, n, nargs;
+      uint32_t nreq, nreq_and_opt, ntotal, npositional;
       int32_t kw_offset;
       scm_t_bits kw_bits;
       SCM kw;
-      char allow_other_keys, has_rest;
+      uint8_t allow_other_keys, has_rest;
+      struct scm_vm_intrinsics *i = (void*)intrinsics;
 
       UNPACK_24 (op, nreq);
       allow_other_keys = ip[1] & 0x1;
@@ -1103,67 +1104,17 @@ VM_NAME (scm_i_thread *thread, jmp_buf *registers, int 
resume)
       VM_ASSERT (!(kw_bits & 0x7), abort());
       kw = SCM_PACK (kw_bits);
 
-      nargs = FRAME_LOCALS_COUNT ();
+      /* Note that if nopt == 0 then npositional = nreq.  */
+      npositional = i->compute_kwargs_npositional (thread, nreq,
+                                                   nreq_and_opt - nreq);
 
-      /* look in optionals for first keyword or last positional */
-      /* starting after the last required positional arg */
-      npositional = nreq;
-      while (/* while we have args */
-             npositional < nargs
-             /* and we still have positionals to fill */
-             && npositional < nreq_and_opt
-             /* and we haven't reached a keyword yet */
-             && !scm_is_keyword (FP_REF (npositional)))
-        /* bind this optional arg (by leaving it in place) */
-        npositional++;
-      nkw = nargs - npositional;
-      /* shuffle non-positional arguments above ntotal */
-      ALLOC_FRAME (ntotal + nkw);
-      n = nkw;
-      while (n--)
-        FP_SET (ntotal + n, FP_REF (npositional + n));
-      /* and fill optionals & keyword args with SCM_UNDEFINED */
-      n = npositional;
-      while (n < ntotal)
-        FP_SET (n++, SCM_UNDEFINED);
-
-      /* Now bind keywords, in the order given.  */
-      for (n = 0; n < nkw; n++)
-        if (scm_is_keyword (FP_REF (ntotal + n)))
-          {
-            SCM walk;
-            for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk))
-              if (scm_is_eq (SCM_CAAR (walk), FP_REF (ntotal + n)))
-                {
-                  SCM si = SCM_CDAR (walk);
-                  if (n + 1 < nkw)
-                    {
-                      FP_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : 
scm_to_uint32 (si),
-                              FP_REF (ntotal + n + 1));
-                    }
-                  else
-                    vm_error_kwargs_missing_value (FP_REF (0),
-                                                   FP_REF (ntotal + n));
-                  break;
-                }
-            VM_ASSERT (scm_is_pair (walk) || allow_other_keys,
-                       vm_error_kwargs_unrecognized_keyword (FP_REF (0),
-                                                             FP_REF (ntotal + 
n)));
-            n++;
-          }
-        else
-          VM_ASSERT (has_rest, vm_error_kwargs_invalid_keyword (FP_REF (0),
-                                                                FP_REF (ntotal 
+ n)));
+      SYNC_IP ();
+      i->bind_kwargs(thread, npositional, ntotal, kw, !has_rest,
+                     allow_other_keys);
+      CACHE_SP ();
 
       if (has_rest)
-        {
-          SCM rest = SCM_EOL;
-          n = nkw;
-          SYNC_IP ();
-          while (n--)
-            rest = scm_inline_cons (thread, FP_REF (ntotal + n), rest);
-          FP_SET (nreq_and_opt, rest);
-        }
+        FP_SET (nreq_and_opt, i->cons_rest (thread, ntotal));
 
       RESET_FRAME (ntotal);
 
diff --git a/libguile/vm.c b/libguile/vm.c
index bf77c01..5c13deb 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -463,9 +463,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_kwargs_missing_value (SCM proc, SCM kw) SCM_NORETURN 
SCM_NOINLINE;
-static void vm_error_kwargs_invalid_keyword (SCM proc, SCM obj) SCM_NORETURN 
SCM_NOINLINE;
-static void vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw) 
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;
@@ -530,30 +527,6 @@ vm_error_apply_to_non_list (SCM x)
 }
 
 static void
-vm_error_kwargs_missing_value (SCM proc, SCM kw)
-{
-  scm_error_scm (sym_keyword_argument_error, proc,
-                 scm_from_latin1_string ("Keyword argument has no value"),
-                 SCM_EOL, scm_list_1 (kw));
-}
-
-static void
-vm_error_kwargs_invalid_keyword (SCM proc, SCM obj)
-{
-  scm_error_scm (sym_keyword_argument_error, proc,
-                 scm_from_latin1_string ("Invalid keyword"),
-                 SCM_EOL, scm_list_1 (obj));
-}
-
-static void
-vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw)
-{
-  scm_error_scm (sym_keyword_argument_error, proc,
-                 scm_from_latin1_string ("Unrecognized keyword"),
-                 SCM_EOL, scm_list_1 (kw));
-}
-
-static void
 vm_error_wrong_num_args (SCM proc)
 {
   scm_wrong_num_args (proc);
@@ -1158,12 +1131,136 @@ vm_expand_stack (struct scm_vm *vp, union 
scm_vm_stack_element *new_sp)
     }
 }
 
+static uint32_t
+frame_locals_count (scm_i_thread *thread)
+{
+  return SCM_FRAME_NUM_LOCALS (thread->vm.fp, thread->vm.sp);
+}
+
 static void
 thread_expand_stack (scm_i_thread *thread, union scm_vm_stack_element *new_sp)
 {
   vm_expand_stack (&thread->vm, new_sp);
 }
 
+/* This duplicates the inlined "ALLOC_FRAME" macro from vm-engine.c, but
+   it seems to be necessary for perf; the inlined version avoids the
+   needs to flush IP in the common case.  */
+static void
+alloc_frame (scm_i_thread *thread, uint32_t nlocals)
+{
+  union scm_vm_stack_element *sp = thread->vm.fp - nlocals;
+
+  if (sp < thread->vm.sp_min_since_gc)
+    {
+      if (SCM_UNLIKELY (sp < thread->vm.stack_limit))
+        thread_expand_stack (thread, sp);
+      else
+        thread->vm.sp_min_since_gc = thread->vm.sp = sp;
+    }
+  else
+    thread->vm.sp = sp;
+}
+
+static uint32_t
+compute_kwargs_npositional (scm_i_thread *thread, uint32_t nreq, uint32_t nopt)
+{
+  uint32_t npositional, nargs;
+
+  nargs = frame_locals_count (thread);
+
+  /* look in optionals for first keyword or last positional */
+  /* starting after the last required positional arg */
+  npositional = nreq;
+  while (/* while we have args */
+         npositional < nargs
+         /* and we still have positionals to fill */
+         && npositional < nreq + nopt
+         /* and we haven't reached a keyword yet */
+         && !scm_is_keyword (SCM_FRAME_LOCAL (thread->vm.fp, npositional)))
+    /* bind this optional arg (by leaving it in place) */
+    npositional++;
+
+  return npositional;
+}
+
+static void
+bind_kwargs (scm_i_thread *thread, uint32_t npositional, uint32_t nlocals,
+             SCM kwargs, uint8_t strict, uint8_t allow_other_keys)
+{
+  uint32_t nargs, nkw, n;
+  union scm_vm_stack_element *fp;
+
+  nargs = frame_locals_count (thread);
+  nkw = nargs - npositional;
+
+  /* shuffle non-positional arguments above nlocals */
+  alloc_frame (thread, nlocals + nkw);
+
+  fp = thread->vm.fp;
+  n = nkw;
+  while (n--)
+    SCM_FRAME_LOCAL (fp, nlocals + n) = SCM_FRAME_LOCAL (fp, npositional + n);
+
+  /* Fill optionals & keyword args with SCM_UNDEFINED */
+  n = npositional;
+  while (n < nlocals)
+    SCM_FRAME_LOCAL (fp, n++) = SCM_UNDEFINED;
+
+  /* Now bind keywords, in the order given.  */
+  for (n = 0; n < nkw; n++)
+    {
+      SCM kw = SCM_FRAME_LOCAL (fp, nlocals + n);
+
+      if (scm_is_keyword (kw))
+        {
+          SCM walk;
+          for (walk = kwargs; scm_is_pair (walk); walk = SCM_CDR (walk))
+            if (scm_is_eq (SCM_CAAR (walk), kw))
+              {
+                SCM si = SCM_CDAR (walk);
+                if (n + 1 < nkw)
+                  SCM_FRAME_LOCAL (fp, scm_to_uint32 (si)) =
+                    SCM_FRAME_LOCAL (fp, nlocals + n + 1);
+                else
+                  scm_error_scm (sym_keyword_argument_error, SCM_BOOL_F,
+                                 scm_from_latin1_string
+                                 ("Keyword argument has no value"),
+                                 SCM_EOL, scm_list_1 (kw));
+                break;
+              }
+          if (!allow_other_keys && !scm_is_pair (walk))
+            scm_error_scm (sym_keyword_argument_error, SCM_BOOL_F,
+                           scm_from_latin1_string ("Unrecognized keyword"),
+                           SCM_EOL, scm_list_1 (kw));
+          n++;
+        }
+      else if (strict)
+        {
+          scm_error_scm (sym_keyword_argument_error, SCM_BOOL_F,
+                         scm_from_latin1_string ("Invalid keyword"),
+                         SCM_EOL, scm_list_1 (kw));
+        }
+      else
+        {
+          /* Ignore this argument.  It might get consed onto a rest list.  */
+        }
+    }
+}
+
+static SCM
+cons_rest (scm_i_thread *thread, uint32_t base)
+{
+  SCM rest = SCM_EOL;
+  uint32_t n = frame_locals_count (thread) - base;
+
+  while (n--)
+    rest = scm_inline_cons (thread, SCM_FRAME_LOCAL (thread->vm.fp, base + n),
+                            rest);
+
+  return rest;
+}
+
 SCM
 scm_call_n (SCM proc, SCM *argv, size_t nargs)
 {
@@ -1503,6 +1600,9 @@ scm_bootstrap_vm (void)
                             NULL);
 
   scm_vm_intrinsics.expand_stack = thread_expand_stack;
+  scm_vm_intrinsics.cons_rest = cons_rest;
+  scm_vm_intrinsics.compute_kwargs_npositional = compute_kwargs_npositional;
+  scm_vm_intrinsics.bind_kwargs = bind_kwargs;
 
   sym_vm_run = scm_from_latin1_symbol ("vm-run");
   sym_vm_error = scm_from_latin1_symbol ("vm-error");