[Guile-commits] 13/13: Add instrumentation to VM builtins

[Andy Wingo]

wingo pushed a commit to branch lightning
in repository guile.

commit 3827769aff190a5e155b29d37fe157dd6115ad04
Author: Andy Wingo <address@hidden>
Date:   Fri Aug 17 08:15:04 2018 +0200

    Add instrumentation to VM builtins
    
    * libguile/intrinsics.h: Add "intrinsic" for handle-interrupts code.
      Unlike the other intrinsics, this one isn't a function.
    * libguile/programs.c (try_parse_arity): Add cases for instructions used
      in VM builtins.
      (scm_primitive_call_ip): Return #f if call-ip not found.
    * libguile/vm-engine.c (handle-interrupts): Get code from intrinsics.
    * libguile/vm.c
    * libguile/vm.c (instrumented_code, define_vm_builtins): Add
      instrumentation to the builtins, so that they can be JIT-compiled.
      (INIT_BUILTIN): Remove min-arity setting; the fallback min-arity
      interpreter should figure it out.
      (scm_bootstrap_vm): Call the new define_vm_builtins function.
    * libguile/gsubr.c (primitive_call_ip): Return 0 if call IP not found.
      (primitive_subr_idx): Interpret call ip == 0 as not-a-subr.
    * module/system/vm/program.scm (program-arguments-alist): Allow a #f
      call-ip.
---
 libguile/gsubr.c             |   7 ++-
 libguile/intrinsics.h        |   2 +
 libguile/programs.c          |  12 +++-
 libguile/vm-engine.c         |   2 +-
 libguile/vm.c                | 135 ++++++++++++++++++++++++-------------------
 module/system/vm/program.scm |   2 +-
 6 files changed, 97 insertions(+), 63 deletions(-)

diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index 227796e..2384776 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -400,7 +400,7 @@ primitive_call_ip (const uint32_t *code)
           code -= 1;
           break;
         default:
-          abort ();
+          return 0;
         }
     }
 }
@@ -410,8 +410,11 @@ static const uint32_t NOT_A_SUBR_CALL = 0xffffffff;
 static uint32_t
 primitive_subr_idx (const uint32_t *code)
 {
+  uint32_t word;
   uintptr_t call_ip = primitive_call_ip (code);
-  uint32_t word = ((uint32_t *) call_ip)[0];
+  if (call_ip == 0)
+    return NOT_A_SUBR_CALL;
+  word = ((uint32_t *) call_ip)[0];
   if ((word & 0xff) == scm_op_subr_call)
     {
       uint32_t idx = word >> 8;
diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h
index b004711..30e85c5 100644
--- a/libguile/intrinsics.h
+++ b/libguile/intrinsics.h
@@ -92,6 +92,7 @@ typedef SCM (*scm_t_scm_from_ptr_intrinsic) (SCM*);
 typedef void (*scm_t_ptr_scm_intrinsic) (SCM*, SCM);
 typedef SCM (*scm_t_scm_from_ptr_scm_intrinsic) (SCM*, SCM);
 typedef SCM (*scm_t_scm_from_ptr_scm_scm_intrinsic) (SCM*, SCM, SCM);
+typedef uint32_t* scm_t_vcode_intrinsic;
 
 #define SCM_FOR_ALL_VM_INTRINSICS(M) \
   M(scm_from_scm_scm, add, "add", ADD) \
@@ -167,6 +168,7 @@ typedef SCM (*scm_t_scm_from_ptr_scm_scm_intrinsic) (SCM*, 
SCM, SCM);
   M(ptr_scm, atomic_set_scm, "atomic-set-scm", ATOMIC_SET_SCM) \
   M(scm_from_ptr_scm, atomic_swap_scm, "atomic-swap-scm", ATOMIC_SWAP_SCM) \
   M(scm_from_ptr_scm_scm, atomic_compare_and_swap_scm, 
"atomic-compare-and-swap-scm", ATOMIC_COMPARE_AND_SWAP_SCM) \
+  M(vcode, handle_interrupt_code, "%handle-interrupt-code", 
HANDLE_INTERRUPT_CODE) \
   /* Add new intrinsics here; also update scm_bootstrap_intrinsics.  */
 
 enum scm_vm_intrinsic
diff --git a/libguile/programs.c b/libguile/programs.c
index 8d2b04e..2741147 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -172,9 +172,12 @@ SCM_DEFINE (scm_primitive_call_ip, "primitive-call-ip", 1, 
0, 0,
            "")
 #define FUNC_NAME s_scm_primitive_call_ip
 {
+  uintptr_t ip;
+
   SCM_MAKE_VALIDATE (1, prim, PRIMITIVE_P);
 
-  return scm_from_uintptr_t (scm_i_primitive_call_ip (prim));
+  ip = scm_i_primitive_call_ip (prim);
+  return ip ? scm_from_uintptr_t (ip) : SCM_BOOL_F;
 }
 #undef FUNC_NAME
 
@@ -312,11 +315,18 @@ try_parse_arity (SCM program, int *req, int *opt, int 
*rest)
       *opt = slots - min;
       *rest = 1;
       return 1;
+    case scm_op_shuffle_down:
+    case scm_op_abort:
+      *req = min - 1;
+      *opt = 0;
+      *rest = 1;
+      return 1;
     default:
       return 0;
     }
   case scm_op_continuation_call:
   case scm_op_compose_continuation:
+  case scm_op_shuffle_down:
     *req = 0;
     *opt = 0;
     *rest = 1;
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 2af02dc..e8787ee 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -2385,7 +2385,7 @@ VM_NAME (scm_thread *thread)
       SYNC_IP ();
       CALL_INTRINSIC (push_interrupt_frame, (thread, 0));
       CACHE_SP ();
-      ip = (uint32_t *) vm_handle_interrupt_code;
+      ip = scm_vm_intrinsics.handle_interrupt_code;
 
       NEXT (0);
     }
diff --git a/libguile/vm.c b/libguile/vm.c
index ee22ad5..e14e5fe 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -300,60 +300,17 @@ vm_error_bad_instruction (uint32_t inst)
 
 
 static SCM vm_boot_continuation;
-static SCM vm_builtin_apply;
-static SCM vm_builtin_values;
-static SCM vm_builtin_abort_to_prompt;
-static SCM vm_builtin_call_with_values;
-static SCM vm_builtin_call_with_current_continuation;
+
+#define DECLARE_BUILTIN(builtin, BUILTIN, req, opt, rest)               \
+  static SCM vm_builtin_##builtin;                                      \
+  static uint32_t *vm_builtin_##builtin##_code;
+FOR_EACH_VM_BUILTIN (DECLARE_BUILTIN)
+#undef DECLARE_BUILTIN
 
 static const uint32_t vm_boot_continuation_code[] = {
   SCM_PACK_OP_24 (halt, 0)
 };
 
-static const uint32_t vm_builtin_apply_code[] = {
-  SCM_PACK_OP_24 (assert_nargs_ge, 3),
-  SCM_PACK_OP_12_12 (shuffle_down, 1, 0),
-  SCM_PACK_OP_24 (expand_apply_argument, 0),
-  SCM_PACK_OP_24 (tail_call, 0),
-};
-
-static const uint32_t vm_builtin_values_code[] = {
-  SCM_PACK_OP_12_12 (shuffle_down, 1, 0),
-  SCM_PACK_OP_24 (return_values, 0)
-};
-
-static const uint32_t vm_builtin_abort_to_prompt_code[] = {
-  SCM_PACK_OP_24 (assert_nargs_ge, 2),
-  SCM_PACK_OP_24 (abort, 0), /* tag in r1, vals from r2 */
-  /* FIXME: Partial continuation should capture caller regs.  */
-  SCM_PACK_OP_24 (return_values, 0) /* vals from r0 */
-};
-
-static const uint32_t vm_builtin_call_with_values_code[] = {
-  SCM_PACK_OP_24 (assert_nargs_ee, 3),
-  SCM_PACK_OP_24 (alloc_frame, 8),
-  SCM_PACK_OP_12_12 (mov, 0, 6),
-  SCM_PACK_OP_24 (call, 7), SCM_PACK_OP_ARG_8_24 (0, 1),
-  SCM_PACK_OP_24 (long_fmov, 0), SCM_PACK_OP_ARG_8_24 (0, 2),
-  SCM_PACK_OP_12_12 (shuffle_down, 7, 1),
-  SCM_PACK_OP_24 (tail_call, 0)
-};
-
-static const uint32_t vm_builtin_call_with_current_continuation_code[] = {
-  SCM_PACK_OP_24 (assert_nargs_ee, 2),
-  SCM_PACK_OP_12_12 (mov, 1, 0),
-  SCM_PACK_OP_24 (capture_continuation, 0),
-  SCM_PACK_OP_24 (tail_call, 0)
-};
-
-static const uint32_t vm_handle_interrupt_code[] = {
-  SCM_PACK_OP_24 (alloc_frame, 4),
-  SCM_PACK_OP_12_12 (mov, 0, 3),
-  SCM_PACK_OP_24 (call, 3), SCM_PACK_OP_ARG_8_24 (0, 1),
-  SCM_PACK_OP_24 (return_from_interrupt, 0)
-};
-
-
 int
 scm_i_vm_is_boot_continuation_code (uint32_t *ip)
 {
@@ -423,6 +380,75 @@ scm_init_vm_builtins (void)
                       scm_vm_builtin_index_to_name);
 }
 
+static uint32_t*
+instrumented_code (const uint32_t *code, size_t byte_size)
+{
+  uint32_t *ret, *write;
+  ret = scm_i_alloc_primitive_code_with_instrumentation (byte_size / 4, 
&write);
+  memcpy (write, code, byte_size);
+  return ret;
+}
+
+static void
+define_vm_builtins (void)
+{
+  const uint32_t apply_code[] = {
+    SCM_PACK_OP_24 (assert_nargs_ge, 3),
+    SCM_PACK_OP_12_12 (shuffle_down, 1, 0),
+    SCM_PACK_OP_24 (expand_apply_argument, 0),
+    SCM_PACK_OP_24 (tail_call, 0),
+  };
+
+  const uint32_t values_code[] = {
+    SCM_PACK_OP_12_12 (shuffle_down, 1, 0),
+    SCM_PACK_OP_24 (return_values, 0)
+  };
+
+  const uint32_t abort_to_prompt_code[] = {
+    SCM_PACK_OP_24 (assert_nargs_ge, 2),
+    SCM_PACK_OP_24 (abort, 0), /* tag in r1, vals from r2 */
+    /* FIXME: Partial continuation should capture caller regs.  */
+    SCM_PACK_OP_24 (return_values, 0) /* vals from r0 */
+  };
+
+  const uint32_t call_with_values_code[] = {
+    SCM_PACK_OP_24 (assert_nargs_ee, 3),
+    SCM_PACK_OP_24 (alloc_frame, 8),
+    SCM_PACK_OP_12_12 (mov, 0, 6),
+    SCM_PACK_OP_24 (call, 7), SCM_PACK_OP_ARG_8_24 (0, 1),
+    SCM_PACK_OP_24 (long_fmov, 0), SCM_PACK_OP_ARG_8_24 (0, 2),
+    SCM_PACK_OP_12_12 (shuffle_down, 7, 1),
+    SCM_PACK_OP_24 (tail_call, 0)
+  };
+
+  const uint32_t call_with_current_continuation_code[] = {
+    SCM_PACK_OP_24 (assert_nargs_ee, 2),
+    SCM_PACK_OP_12_12 (mov, 1, 0),
+    SCM_PACK_OP_24 (capture_continuation, 0),
+    SCM_PACK_OP_24 (tail_call, 0)
+  };
+
+  /* This one isn't exactly a builtin but we still handle it here.  */
+  const uint32_t handle_interrupt_code[] = {
+    SCM_PACK_OP_24 (alloc_frame, 4),
+    SCM_PACK_OP_12_12 (mov, 0, 3),
+    SCM_PACK_OP_24 (call, 3), SCM_PACK_OP_ARG_8_24 (0, 1),
+    SCM_PACK_OP_24 (return_from_interrupt, 0)
+  };
+
+#define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest)                \
+  {                                                                     \
+    size_t sz = sizeof (builtin##_code);                                \
+    vm_builtin_##builtin##_code = instrumented_code (builtin##_code, sz); \
+    vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code); \
+  }
+  FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN);
+#undef INDEX_TO_NAME
+
+  scm_vm_intrinsics.handle_interrupt_code =
+    instrumented_code (handle_interrupt_code, sizeof (handle_interrupt_code));
+}
+
 SCM
 scm_i_call_with_current_continuation (SCM proc)
 {
@@ -1701,11 +1727,7 @@ scm_init_vm_builtin_properties (void)
 
 #define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest)                  \
   scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name,     \
-                                scm_sym_##builtin);                     \
-  scm_set_procedure_minimum_arity_x (vm_builtin_##builtin,              \
-                                     SCM_I_MAKINUM (req),               \
-                                     SCM_I_MAKINUM (opt),               \
-                                     scm_from_bool (rest));
+                                scm_sym_##builtin);
   FOR_EACH_VM_BUILTIN (INIT_BUILTIN);
 #undef INIT_BUILTIN
 }
@@ -1748,10 +1770,7 @@ scm_bootstrap_vm (void)
                        (SCM_CELL_WORD_0 (vm_boot_continuation)
                         | SCM_F_PROGRAM_IS_BOOT));
 
-#define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest)                \
-  vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code);
-  FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN);
-#undef DEFINE_BUILTIN
+  define_vm_builtins ();
 }
 
 void
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 4f6d9ab..e5dbcc0 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -204,7 +204,7 @@ of integers."
         ((nreq nopt rest?)
          (let ((start (primitive-call-ip prog)))
            ;; Assume that there is only one IP for the call.
-           (and (or (not ip) (= start ip))
+           (and (or (not ip) (and start (= start ip)))
                 (arity->arguments-alist
                  prog
                  (list 0 0 nreq nopt rest? '(#f . ()))))))))